-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- Copyright 2009, Henning Thielemann.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright notice,
--    this list of conditions and the following disclaimer.
--
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--
--  * Neither the name of the copyright holder(s) nor the names of
--    contributors may be used to endorse or promote products derived from
--    this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- -----------------------------------------------------------------------------

module Network.MoHWS.HTTP.MimeType (
   Dictionary,
   T(Cons),
   loadDictionary,
   fromFileName,
   ) where

import Network.MoHWS.ParserUtility

import Data.Map (Map)
import qualified Data.Map as Map
import Text.ParserCombinators.Parsec
          (Parser, parse, char, spaces, sepBy, )
import qualified System.FilePath as FilePath
import Control.Monad (liftM2, guard, )
import Data.Maybe (mapMaybe, )
import Data.List.HT (viewL, )


type Dictionary = Map String T

data T = Cons String String

instance Show T where
   showsPrec :: Int -> T -> ShowS
showsPrec Int
_ (Cons String
part1 String
part2) = String -> ShowS
showString (String
part1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:String
part2)

fromFileName :: Dictionary -> FilePath -> Maybe T
fromFileName :: Dictionary -> String -> Maybe T
fromFileName Dictionary
mime_types String
filename =
   do (Char
sep,String
ext) <- String -> Maybe (Char, String)
forall a. [a] -> Maybe (a, [a])
viewL (String -> Maybe (Char, String)) -> String -> Maybe (Char, String)
forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeExtension String
filename
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
FilePath.isExtSeparator Char
sep)
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ext)
      String -> Dictionary -> Maybe T
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ext Dictionary
mime_types

loadDictionary :: FilePath -> IO Dictionary
loadDictionary :: String -> IO Dictionary
loadDictionary String
mime_types_file =
   (String -> Dictionary) -> IO String -> IO Dictionary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(String, T)] -> Dictionary
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, T)] -> Dictionary)
-> (String -> [(String, T)]) -> String -> Dictionary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, T)]
parseDictionary) (IO String -> IO Dictionary) -> IO String -> IO Dictionary
forall a b. (a -> b) -> a -> b
$
   String -> IO String
readFile String
mime_types_file

parseDictionary :: String -> [(String,T)]
parseDictionary :: String -> [(String, T)]
parseDictionary String
file =
   do (T
val,[String]
exts) <- (String -> Maybe (T, [String])) -> [String] -> [(T, [String])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe (T, [String])
parseMimeLine (String -> Maybe (T, [String]))
-> ShowS -> String -> Maybe (T, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#')) (String -> [String]
lines String
file)
      String
ext <- [String]
exts
      (String, T) -> [(String, T)]
forall (m :: * -> *) a. Monad m => a -> m a
return (String
ext,T
val)

parseMimeLine :: String -> Maybe (T, [String])
parseMimeLine :: String -> Maybe (T, [String])
parseMimeLine String
l =
   case Parsec String () (T, [String])
-> String -> String -> Either ParseError (T, [String])
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (T, [String])
parserLine String
"MIME line" String
l of
      Left ParseError
_  -> Maybe (T, [String])
forall a. Maybe a
Nothing
      Right (T, [String])
m -> (T, [String]) -> Maybe (T, [String])
forall a. a -> Maybe a
Just (T, [String])
m

parserLine :: Parser (T, [String])
parserLine :: Parsec String () (T, [String])
parserLine =
   (T -> [String] -> (T, [String]))
-> ParsecT String () Identity T
-> ParsecT String () Identity [String]
-> Parsec String () (T, [String])
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) ParsecT String () Identity T
parser (ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity [String]
-> ParsecT String () Identity [String]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity String
-> ParsecT String () Identity ()
-> ParsecT String () Identity [String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy ParsecT String () Identity String
pToken ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces)

parser :: Parser T
parser :: ParsecT String () Identity T
parser =
   (String -> String -> T)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity T
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 String -> String -> T
Cons ParsecT String () Identity String
pToken (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/' ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity String
pToken)