{-# LANGUAGE
    OverloadedStrings
  , UnicodeSyntax
  #-}
module Main where
import Codec.Compression.GZip
import Control.Applicative
import Control.Monad
import qualified Data.Ascii as A
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.Digest.Pure.SHA
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)
               $ fail "too many input files."

          generateHaskellSource opts (head sources)

generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
generateHaskellSource opts srcFile
    = do modName ← getModuleName opts
         symName ← getSymbolName opts modName
         mType   ← getMIMEType opts srcFile
         lastMod ← getLastModified srcFile
         input   ← openInput srcFile
         output  ← openOutput opts
         tag     ← 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 mType tag lastMod

         let hsModule = mkModule modName symName imports decls
             imports  = mkImports useGZip
             decls    = concat [ resourceDecl symName useGZip
                               , entityTagDecl tag
                               , lastModifiedDecl lastMod
                               , contentTypeDecl mType
                               , if useGZip then
                                     dataDecl (name "gzippedData") gzippedB64
                                 else
                                     dataDecl (name "rawData") rawB64
                               ]

         hPutStrLn output header
         hPutStrLn output (prettyPrint hsModule)
         hClose output

mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module
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 Nothing (Just (ModuleName "B64")) Nothing
      , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
                   True False Nothing (Just (ModuleName "Lazy")) Nothing
      , ImportDecl (⊥) (ModuleName "Data.Time")
                   False False Nothing Nothing Nothing
      , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
                   False False Nothing Nothing Nothing
      ]
      ⧺
      [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
                   False False Nothing Nothing Nothing
        | useGZip ]

resourceDecl ∷ Name → Bool → [Decl]
resourceDecl symName useGZip
    = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
      , nameBind (⊥) symName valExp
      ]
    where
      valExp ∷ Exp
      valExp = RecUpdate (function "emptyResource")
               [ FieldUpdate (UnQual (name "resGet" )) resGet
               , FieldUpdate (UnQual (name "resHead")) resHead
               ]

      resGet ∷ Exp
      resGet | useGZip   = resGetGZipped
             | otherwise = resGetRaw

resHead ∷ Exp
resHead
    = function "Just" `app`
      paren (doE [ foundEntityStmt
                 , setContentTypeStmt
                 ])

resGetGZipped ∷ Exp
resGetGZipped
    = function "Just" `app`
      paren (doE [ foundEntityStmt
                 , setContentTypeStmt
                 , bindGZipStmt
                 , conditionalOutputStmt
                 ])
    where
      condVarName ∷ Name
      condVarName = name "gzipAllowed"

      dataVarName ∷ Name
      dataVarName = name "gzippedData"

      bindGZipStmt ∷ Stmt
      bindGZipStmt
          = genStmt (⊥)
            (pvar condVarName)
            (function "isEncodingAcceptable" `app` strE "gzip")

      conditionalOutputStmt ∷ Stmt
      conditionalOutputStmt
          = qualStmt $
            If (var condVarName)
               (doE [ setContentEncodingGZipStmt
                    , putChunksStmt (var dataVarName)
                    ])
               (putChunksExp
                (paren
                 (function "decompress" `app` var dataVarName)))

resGetRaw ∷ Exp
resGetRaw
    = function "Just" `app`
      paren (doE [ foundEntityStmt
                 , setContentTypeStmt
                 , putChunksStmt (function "rawData")
                 ])

setContentEncodingGZipStmt ∷ Stmt
setContentEncodingGZipStmt
    = qualStmt
      ( function "setContentEncoding"
        `app`
        listE [ strE "gzip" ]
      )

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

setContentTypeStmt ∷ Stmt
setContentTypeStmt
    = qualStmt
      ( function "setContentType"
        `app`
        function "contentType"
      )

putChunksExp ∷ Exp → Exp
putChunksExp = app (function "putChunks")

putChunksStmt ∷ Exp → Stmt
putChunksStmt = qualStmt ∘ putChunksExp

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

      valExp ∷ Exp
      valExp = function "parseETag" `app` strE (eTagToString tag)

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

      valExp ∷ Exp
      valExp = function "read" `app` strE (show lastMod)

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

      valExp ∷ Exp
      valExp = function "parseMIMEType" `app` strE (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
      , InlineSig (⊥) False AlwaysActive (UnQual varName)
      ]
    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 → ETag → UTCTime → IO String
mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod
    = do localLastMod ← utcToLocalZonedTime lastMod
         return $ concat
                    [ "{- 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: ", mimeTypeToString mType, "\n"
                    , "                ETag: ", eTagToString tag, "\n"
                    , "       Last Modified: ", show localLastMod, "\n"
                    , " -}"
                    ]

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

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

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

getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
getSymbolName opts (ModuleName modName)
    = case symNameOpts of
        []                    → return defaultSymName
        OptSymName symName:[] → return $ name symName
        _                     → fail "too many --symbol options."
    where
      symNameOpts ∷ [CmdOpt]
      symNameOpts = filter (\ x → case x of
                                     OptSymName _ → True
                                     _            → False) opts

      defaultSymName ∷ Name
      defaultSymName
          = name $ headToLower $ getLastComp modName

      headToLower ∷ String → String
      headToLower []     = error "module name must not be empty"
      headToLower (x:xs) = toLower x : xs

      getLastComp ∷ String → String
      getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse

getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
getMIMEType opts srcFile
    = case mimeTypeOpts of
        []  → return defaultType
        OptMIMEType ty:[]
            → case A.fromChars ty of
                 Just a  → return $ parseMIMEType a
                 Nothing → fail "MIME type must not contain any non-ASCII letters."
        _   → fail "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 ETag
getETag opts input
    = case eTagOpts of
        []             → return mkETagFromInput
        OptETag str:[] → return $ strToETag str
        _              → fail "too many --etag options."
    where
      eTagOpts ∷ [CmdOpt]
      eTagOpts = filter (\ x → case x of
                                  OptETag _ → True
                                  _         → False) opts

      mkETagFromInput ∷ ETag
      mkETagFromInput
          = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)

      strToETag ∷ String → ETag
      strToETag str
          = case A.fromChars str of
              Just a  → strongETag a
              Nothing → error "ETag must not contain any non-ASCII letters."

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

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

{-
  作られるファイルの例 (壓縮されない場合):
  ------------------------------------------------------------------------------
  {- 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
                        putChunk rawData
        , resHead
            = Just $ do foundEntity entityTag lastModified
                        setContentType contentType
        , resPost   = Nothing
        , resPut    = Nothing
        , resDelete = Nothing
        }

  entityTag ∷ ETag
  entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"

  lastModified ∷ UTCTime
  {-# NOINLINE lastModified #-}
  lastModified = read "2007-11-05 04:47:56.008366 UTC"

  contentType ∷ MIMEType
  {-# NOINLINE contentType #-}
  contentType = parseMIMEType "image/png"

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

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

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

                        gzipAllowed ← isEncodingAcceptable "gzip"
                        if gzipAllowed then
                            do setContentEncoding ["gzip"]
                               putChunks gzippedData
                        else
                            putChunks (decompress gzippedData)
        , resHead
            = Just $ do foundEntity entityTag lastModified
                        setContentType contentType
        , resPost   = Nothing
        , resPut    = Nothing
        , resDelete = Nothing
        }

  -- rawData の代はりに gzippedData
  gzippedData ∷ Lazy.ByteString
  {-# NOINLINE gzippedData #-}
  gzippedData = Lazy.fromChunks
                [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
                , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
                ]
  ------------------------------------------------------------------------------
 -}