{-# LANGUAGE
    DeriveDataTypeable
  , GeneralizedNewtypeDeriving
  , MultiParamTypeClasses
  , TemplateHaskell
  , UnicodeSyntax
  , ViewPatterns
  #-}
-- |Guessing MIME Types by file extensions. It's not always accurate
-- but simple and fast.
--
-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.MIMEType.Guess
    ( ExtMap(..)
    , extMap
    , guessTypeByFileName
    )
    where
import Control.Applicative
import Data.Attoparsec.Char8
import qualified Data.Attoparsec.Lazy as LP
import Data.Attoparsec.Parsable
import qualified Data.ByteString.Lazy.Char8 as Lazy
import Data.Convertible.Base
import Data.Convertible.Instances.Text ()
import qualified Data.Map as M
import Data.Map (Map)
import Data.Typeable
import Data.List
import Data.Monoid
import Data.Monoid.Unicode
import Data.Text (Text)
import Data.Text.Encoding
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
import Prelude.Unicode
import System.FilePath

-- |A 'Map' from file extensions to 'MIMEType's.
newtype ExtMap
    = ExtMap (Map Text MIMEType)
    deriving (Eq, Show, Read, Monoid, Typeable)

instance Lift ExtMap where
    lift (ExtMap m) = [| ExtMap $(lift m) |]

-- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
--
-- @
--   m :: 'ExtMap'
--   m = ['extMap'|
--   # MIME Type            Extensions
--   application/xhtml+xml  xhtml
--   image/jpeg             jpeg jpg
--   image/png              png
--   image/svg+xml          svg
--   text/html              html
--   text/plain             txt
--   |]
-- @
extMap ∷ QuasiQuoter
extMap = QuasiQuoter {
             quoteExp  = lift ∘ parseExtMap ∘ Lazy.pack
           , quotePat  = const unsupported
           , quoteType = const unsupported
           , quoteDec  = const unsupported
         }
    where
      parseExtMap ∷ Lazy.ByteString → ExtMap
      parseExtMap = convertUnsafe

      unsupported ∷ Monad m ⇒ m α
      unsupported = fail "Unsupported usage of extMap quasi-quoter."

instance ConvertAttempt Lazy.ByteString ExtMap where
    convertAttempt src
        = case LP.parse pairs src of
            LP.Fail _ eCtx e
                → fail $ "Unparsable extension map: "
                       ⊕ intercalate ", " eCtx
                       ⊕ ": "
                       ⊕ e
            LP.Done _ xs
                → case compile xs of
                     Right m → return $ ExtMap m
                     Left  e → fail $ "Duplicate extension: " ⊕ show e
        where
          pairs ∷ Parser [(MIMEType, [Text])]
          pairs = do skipMany linebreak
                     xs ← sepBy pair (skipMany1 linebreak)
                     skipMany linebreak
                     endOfInput
                     return xs
                  <?>
                  "pairs"

          pair ∷ Parser (MIMEType, [Text])
          pair = do skipSpace
                    mime ← parser
                    skipSpace1
                    exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
                    return (mime, exts)
                 <?>
                 "pair"

          ext ∷ Parser Text
          ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
                <?>
                "ext"

          linebreak ∷ Parser ()
          linebreak
              = ( endOfLine
                  <|>
                  try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
                )
                <?>
                "linebreak"

compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
compile = go (∅) ∘ concat ∘ (tr <$>)
    where
      tr ∷ (v, [k]) → [(k, v)]
      tr (v, ks) = [(k, v) | k ← ks]

      go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
      go m []         = Right m
      go m ((k, v):xs)
          = case M.insertLookupWithKey' f k v m of
              (Nothing, m') → go m' xs
              (Just v0, _ ) → Left (k, v0, v)

      f ∷ k → v → v → v
      f _ _ = id

-- |Guess the MIME Type of a file.
guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
guessTypeByFileName (ExtMap m) fpath
    = case takeExtension fpath of
        []      → Nothing
        (_:ext) → M.lookup (cs ext) m