-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