{-# LANGUAGE
    UnicodeSyntax
  #-}
module Main where
import Codec.Compression.GZip
import Control.Applicative
import Control.Monad
import qualified Data.Ascii as A
import Data.Bits
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.Char
import Data.Int
import Data.Maybe
import Data.Time
import Data.Time.Clock.POSIX
import Language.Haskell.Exts.Build
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.Syntax
import Network.HTTP.Lucu.ETag
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
import Network.HTTP.Lucu.MIMEType.Guess
import Prelude.Unicode
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.Posix.Files
import System.IO

data CmdOpt
    = OptOutput FilePath
    | OptModName String
    | OptSymName String
    | OptMIMEType String
    | OptETag String
    | OptHelp
    deriving (Eq, Show)

options ∷ [OptDescr CmdOpt]
options = [ Option ['o'] ["output"]
                       (ReqArg OptOutput "FILE")
                       "Output to the FILE."

          , Option ['m'] ["module"]
                       (ReqArg OptModName "MODULE")
                       "Specify the resulting module name. (required)"

          , Option ['s'] ["symbol"]
                       (ReqArg OptSymName "SYMBOL")
                       "Specify the resulting symbol name."

          , Option ['t'] ["mime-type"]
                       (ReqArg OptMIMEType "TYPE")
                       "Specify the MIME Type of the file."

          , Option ['e'] ["etag"]
                       (ReqArg OptETag "TAG")
                       "Specify the ETag of the file."

          , Option ['h'] ["help"]
                       (NoArg OptHelp)
                       "Print this message."
          ]

printUsage ∷ IO ()
printUsage = do mapM_ putStrLn msg
                putStr $ usageInfo "Options:" options
                putStrLn ""
    where
      msg = [ ""
            , "Description:"
            , concat [ "  lucu-implant-file is an utility that generates " 
                     , "Haskell code containing an arbitrary file to "
                     , "compile it directly into programs and serve it "
                     , "statically with the Lucu HTTP server."
                     ]
            , ""
            , "Usage:"
            , "  lucu-implant-file [OPTIONS...] FILE"
            , ""
            ]

main ∷ IO ()
main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs

          unless (null errors)
              $ do mapM_ putStr errors
                   exitWith $ ExitFailure 1

          when (any (≡ OptHelp) opts)
              $ do printUsage
                   exitWith ExitSuccess

          when (null sources)
               $ do printUsage
                    exitWith $ ExitFailure 1

          when (length sources ≥ 2)
               $ error "too many input files."

          generateHaskellSource opts (head sources)

generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
generateHaskellSource opts srcFile
    = do modName  ← getModuleName opts
         symName  ← getSymbolName opts modName
         mimeType ← getMIMEType opts srcFile
         lastMod  ← getLastModified srcFile
         input    ← openInput srcFile
         output   ← openOutput opts
         eTag     ← getETag opts input

         let compParams  = defaultCompressParams { compressLevel = bestCompression }
             gzippedData = compressWith compParams input
             originalLen = Lazy.length input
             gzippedLen  = Lazy.length gzippedData
             useGZip     = originalLen > gzippedLen
             rawB64      = B64.encode <$> Lazy.toChunks input
             gzippedB64  = B64.encode <$> Lazy.toChunks gzippedData

         header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod

         let hsModule = mkModule (ModuleName modName) (name symName) imports decls
             imports  = mkImports useGZip
             decls    = concat [ declResourceDef
                               , entityTagDecl eTag
                               , lastModifiedDecl lastMod
                               , contentTypeDecl mimeType
                               , if useGZip then
                                     dataDecl (name "gzippedData") gzippedB64
                                 else
                                     dataDecl (name "rawData") rawB64
                               ]
             declResourceDef
                 = [ HsTypeSig (⊥) [HsIdent symName]
                               (HsQualType []
                                (HsTyCon (UnQual (HsIdent "ResourceDef"))))
                   , HsFunBind [HsMatch (⊥) (HsIdent symName)
                                [] (HsUnGuardedRhs defResourceDef) []]
                   ]

             defResourceDef ∷ HsExp
             defResourceDef 
                 = let defResGet = if useGZip
                                   then defResGetGZipped
                                   else resGetRaw
                   in 
                     (HsRecConstr (UnQual (HsIdent "ResourceDef"))
                      [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
                                      (HsCon (UnQual (HsIdent "False")))
                      , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
                                      (HsCon (UnQual (HsIdent "False")))
                      , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
                      , HsFieldUpdate (UnQual (HsIdent "resHead"))
                                      (HsCon (UnQual (HsIdent "Nothing")))
                      , HsFieldUpdate (UnQual (HsIdent "resPost"))
                                      (HsCon (UnQual (HsIdent "Nothing")))
                      , HsFieldUpdate (UnQual (HsIdent "resPut"))
                                      (HsCon (UnQual (HsIdent "Nothing")))
                      , HsFieldUpdate (UnQual (HsIdent "resDelete"))
                                      (HsCon (UnQual (HsIdent "Nothing")))
                      ]
                     )

             defResGetGZipped ∷ HsExp
             defResGetGZipped
                 = let doExp = HsDo [ foundEntityStmt
                                    , setContentTypeStmt
                                    , bindMustGunzip
                                    , doConditionalOutput
                                    ]
                       bindMustGunzip
                           = HsGenerator (⊥)
                             (HsPVar (HsIdent "mustGunzip"))
                             (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
                                     (HsVar (UnQual (HsIdent "not"))))
                              (HsParen
                               (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
                                      (HsLit (HsString "gzip")))))
                       doConditionalOutput
                           = HsQualifier
                             (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
                                   expOutputGunzipped
                                   expOutputGZipped)
                       expOutputGunzipped
                           = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
                              (HsParen
                               (HsApp (HsVar (UnQual (HsIdent "decompress")))
                                      (HsVar (UnQual (HsIdent "gzippedData"))))))
                       expOutputGZipped
                           = HsDo [ setContentEncodingGZipStmt
                                  , outputStmt (var $ name "gzippedData")
                                  ]
                   in 
                     HsApp (HsCon (UnQual (HsIdent "Just")))
                           (HsParen doExp)

         hPutStrLn output header
         hPutStrLn output (prettyPrint hsModule)
         hClose output

mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl]
mkModule modName symName imports decls
    = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings)
                                           ]
                      ]
          exports   = [ EVar (UnQual symName)
                      ]
      in
        Module (⊥) modName modPragma Nothing (Just exports) imports decls

mkImports ∷ Bool → [ImportDecl]
mkImports useGZip
    = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
                   True False (Just (ModuleName "B64")) Nothing
      , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
                   True False (Just (ModuleName "Lazy")) Nothing
      , ImportDecl (⊥) (ModuleName "Data.Time")
                   False False Nothing Nothing
      , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
                   False False Nothing Nothing
      ]
      ⧺
      if useGZip then
          [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
                       False False Nothing Nothing
          ]
      else
          []

resHead ∷ Exp
resHead
    = infixApp (var $ name "Just")
               (op  $ name "$"   )
               (doE [ foundEntityStmt
                    , setContentTypeStmt
                    ])

resGetRaw ∷ Exp
resGetRaw
    = infixApp (var $ name "Just")
               (op  $ name "$"   )
               (doE [ foundEntityStmt
                    , setContentTypeStmt
                    , outputStmt (var $ name "rawData")
                    ])

setContentEncodingGZipStmt ∷ Stmt
setContentEncodingGZipStmt
    = qualStmt $
      metaFunction "setContentEncoding" $
      [ listE [ strE "gzip" ] ]

foundEntityStmt ∷ Stmt
foundEntityStmt
    = qualStmt $
      metaFunction "foundEntity" $
      [ var $ name "entityTag"
      , var $ name "lastModified"
      ]

setContentTypeStmt ∷ Stmt
setContentTypeStmt
    = qualStmt $
      metaFunction "setContentType" $
      [var $ name "contentType"]

outputStmt ∷ Exp → Stmt
outputStmt e
    = qualStmt $
      metaFunction "output" [e]

entityTagDecl ∷ ETag → [Decl]
entityTagDecl eTag
    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
      , nameBind (⊥) varName valExp
      ]
    where
      varName ∷ Name
      varName = name "entityTag"

      valExp ∷ Exp
      valExp = metaFunction "parseETag" [strE $ eTagToString eTag]

      eTagToString ∷ ETag → String
      eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag

lastModifiedDecl ∷ UTCTime → [Decl]
lastModifiedDecl lastMod
    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
      , nameBind (⊥) varName valExp
      ]
    where
      varName ∷ Name
      varName = name "lastModified"

      valExp ∷ Exp
      valExp = metaFunction "read" [strE $ show lastMod]

contentTypeDecl ∷ MIMEType → [Decl]
contentTypeDecl mime
    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
      , nameBind (⊥) varName valExp
      ]
    where
      varName ∷ Name
      varName = name "contentType"

      valExp ∷ Exp
      valExp = metaFunction "parseMIMEType" [mimeToString mime]

      mimeToString ∷ MIMEType → String
      mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType

dataDecl ∷ Name → [Strict.ByteString] → [Decl]
dataDecl varName chunks
    = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
      , nameBind (⊥) varName valExp
      ]
    where
      valExp ∷ Exp
      valExp = qvar (ModuleName "Lazy") (name "fromChunks")
               `app`
               listE (chunkToExp <$> chunks)

      chunkToExp ∷ Strict.ByteString → Exp
      chunkToExp chunk
          = qvar (ModuleName "B64") (name "decodeLenient")
            `app`
            strE (Strict.unpack chunk)

mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → String → UTCTime → IO String
mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
    = do localLastMod ← utcToLocalZonedTime lastMod
         return ("{- DO NOT EDIT THIS FILE.\n" ++
                 "   This file is automatically generated by the lucu-implant-file program.\n" ++
                 "\n" ++
                 "              Source: " ++ (if srcFile ≡ "-"
                                              then "(stdin)"
                                              else srcFile) ++ "\n" ++
                 "     Original Length: " ++ show originalLen ++ " bytes\n" ++
                 (if useGZip
                  then "   Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
                       "         Compression: gzip\n"
                  else "         Compression: disabled\n") ++
                 "           MIME Type: " ++ show mimeType ++ "\n" ++
                 "                ETag: " ++ eTag ++ "\n" ++
                 "       Last Modified: " ++ show localLastMod ++ "\n" ++
                 " -}")


getModuleName ∷ [CmdOpt] → IO String
getModuleName opts
    = let modNameOpts = filter (\ x → case x of
                                         OptModName _ → True
                                         _            → False) opts
      in
        case modNameOpts of
          []                      → error "a module name must be given."
          (OptModName modName):[] → return modName
          _                       → error "too many --module options."


getSymbolName ∷ [CmdOpt] → String → IO String
getSymbolName opts modName
    = let symNameOpts    = filter (\ x → case x of
                                            OptSymName _ → True
                                            _            → False) opts
          -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
          -- 小文字にしたものを使ふ。
          defaultSymName  = mkDefault modName
          mkDefault       = headToLower ∘ getLastComp
          headToLower str = case str of
                              []     → error "module name must not be empty"
                              (x:xs) → toLower x : xs
          getLastComp     = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
      in
        case symNameOpts of
          []                      → return defaultSymName
          (OptSymName symName):[] → return symName
          _                       → error "too many --symbol options."


getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
getMIMEType opts srcFile
    = case mimeTypeOpts of
        []                  → return defaultType
        (OptMIMEType ty):[] → return $ read ty
        _                   → error "too many --mime-type options."
    where
      mimeTypeOpts ∷ [CmdOpt]
      mimeTypeOpts
          = filter (\ x → case x of
                             OptMIMEType _ → True
                             _             → False) opts

      octetStream ∷ MIMEType
      octetStream = parseMIMEType "application/octet-stream"

      defaultType ∷ MIMEType
      defaultType = fromMaybe octetStream
                    $ guessTypeByFileName defaultExtensionMap srcFile


getLastModified ∷ FilePath → IO UTCTime
getLastModified "-"   = getCurrentTime
getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
                        <$>
                        getFileStatus fpath


getETag ∷ [CmdOpt] → Lazy.ByteString → IO String
getETag opts input
    = let eTagOpts = filter (\ x → case x of
                                      OptETag _ → True
                                      _         → False) opts
      in
        case eTagOpts of
          []               → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1")
          (OptETag str):[] → return str
          _                → error "too many --etag options."
    where
      mkETagFromInput ∷ Digest → String
      mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)

      toHex ∷ String → String
      toHex = foldr ((++) ∘ hexByte ∘ fromEnum) ""

      hexByte ∷ Int → String
      hexByte n
          = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
            , hex4bit ( n             .&. 0x0F)
            ]

      hex4bit ∷ Int → Char
      hex4bit n
          | n < 10    = chr $ ord '0' + n
          | n < 16    = chr $ ord 'a' + n - 10
          | otherwise = (⊥)


openInput ∷ FilePath → IO Lazy.ByteString
openInput "-"   = Lazy.getContents
openInput fpath = Lazy.readFile fpath


openOutput ∷ [CmdOpt] → IO Handle
openOutput opts
    = let outputOpts = filter (\ x → case x of
                                        OptOutput _ → True
                                        _           → False) opts
      in
        case outputOpts of
          []                   → return stdout
          (OptOutput fpath):[] → openFile fpath WriteMode
          _                    → error "two many --output options."

{-
  作られるファイルの例 (壓縮されない場合):
  ------------------------------------------------------------------------------
  {- DO NOT EDIT THIS FILE.
     This file is automatically generated by the lucu-implant-file program.
     
                Source: baz.png
       Original Length: 302 bytes
     Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
           Compression: disabled
             MIME Type: image/png
                  ETag: d41d8cd98f00b204e9800998ecf8427e
         Last Modified: 2007-11-05 13:53:42.231882 JST
   -}
  {-# LANGUAGE OverloadedStrings #-}
  module Foo.Bar.Baz (baz) where
  import qualified Data.ByteString.Base64 as B64
  import qualified Data.ByteString.Lazy as Lazy
  import Data.Time
  import Network.HTTP.Lucu

  baz ∷ ResourceDef
  baz = ResourceDef {
          resUsesNativeThread = False
        , resIsGreedy         = False
        , resGet
            = Just $ do foundEntity entityTag lastModified
                        setContentType contentType
                        output rawData
        , resHead
            = Just $ do foundEntity entityTag lastModified
                        setContentType contentType
        , resPost   = Nothing
        , resPut    = Nothing
        , resDelete = Nothing
        }

  entityTag ∷ ETag
  entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"

  lastModified ∷ UTCTime
  lastModified = read "2007-11-05 04:47:56.008366 UTC"

  contentType ∷ MIMEType
  contentType = parseMIMEType "image/png"

  rawData ∷ Lazy.ByteString
  rawData = Lazy.fromChunks
            [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
            , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
            ]
  ------------------------------------------------------------------------------

  壓縮される場合は次のやうに變はる:
  ------------------------------------------------------------------------------
  -- import に追加
  import Codec.Compression.GZip

  -- ResourceDef は次のやうに變化
  baz ∷ ResourceDef
  baz = ResourceDef {
          resUsesNativeThread = False
        , resIsGreedy         = False
        , resGet
            = Just $ do foundEntity entityTag lastModified
                        setContentType contentType

                        gzip ← isEncodingAcceptable "gzip"
                        if gzip then
                            do setContentEncoding ["gzip"]
                               output gzippedData
                        else
                            output (decompress gzippedData)
        , resHead
            = Just $ do foundEntity entityTag lastModified
                        setContentType contentType
        , resPost   = Nothing
        , resPut    = Nothing
        , resDelete = Nothing
        }
  
  -- rawData の代はりに gzippedData
  gzippedData ∷ Lazy.ByteString
  gzippedData = Lazy.fromChunks
                [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
                , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
                ]
  ------------------------------------------------------------------------------
 -}