- rawB64 = encode $ L.unpack input
- gzippedB64 = encode $ L.unpack gzippedData
-
- header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
-
- let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
- exports = [HsEVar (UnQual (HsIdent symName))]
- imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
- False Nothing Nothing
- , HsImportDecl undefined (Module "Data.ByteString.Lazy")
- True (Just (Module "L")) Nothing
- , HsImportDecl undefined (Module "Data.Maybe")
- False Nothing Nothing
- , HsImportDecl undefined (Module "Data.Time")
- False Nothing Nothing
- , HsImportDecl undefined (Module "Network.HTTP.Lucu")
- False Nothing Nothing
- ]
- ++
- (if useGZip then
- [ HsImportDecl undefined (Module "Control.Monad")
- False Nothing Nothing
- , HsImportDecl undefined (Module "Codec.Compression.GZip")
- False Nothing Nothing
- ]
- else
- [])
- decls = declResourceDef
- ++
- declEntityTag
- ++
- declLastModified
- ++
- declContentType
- ++
- (if useGZip
- then declGZippedData
- else declRawData)
-
- declResourceDef :: [HsDecl]
- declResourceDef
- = [ HsTypeSig undefined [HsIdent symName]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "ResourceDef"))))
- , HsFunBind [HsMatch undefined (HsIdent symName)
- [] (HsUnGuardedRhs defResourceDef) []]
- ]
-
- defResourceDef :: HsExp
- defResourceDef
- = let defResGet = if useGZip
- then defResGetGZipped
- else defResGetRaw
- 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 [ doFoundEntity
- , doSetContentType
- , bindMustGunzip
- , doConditionalOutput
- ]
- doFoundEntity
- = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
- (HsVar (UnQual (HsIdent "entityTag"))))
- (HsVar (UnQual (HsIdent "lastModified"))))
- doSetContentType
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
- (HsVar (UnQual (HsIdent "contentType"))))
- bindMustGunzip
- = HsGenerator undefined
- (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 [ doSetContentEncodingGZip
- , doOutputGZipped
- ]
- doSetContentEncodingGZip
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
- (HsList [HsLit (HsString "gzip")]))
- doOutputGZipped
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
- (HsVar (UnQual (HsIdent "gzippedData"))))
- in
- HsApp (HsCon (UnQual (HsIdent "Just")))
- (HsParen doExp)
-
- defResGetRaw :: HsExp
- defResGetRaw
- = let doExp = HsDo [ doFoundEntity
- , doSetContentType
- , doOutputRawData
- ]
- doFoundEntity
- = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
- (HsVar (UnQual (HsIdent "entityTag"))))
- (HsVar (UnQual (HsIdent "lastModified"))))
- doSetContentType
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
- (HsVar (UnQual (HsIdent "contentType"))))
- doOutputRawData
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
- (HsVar (UnQual (HsIdent "rawData"))))
- in
- HsApp (HsCon (UnQual (HsIdent "Just")))
- (HsParen doExp)
-
- declEntityTag :: [HsDecl]
- declEntityTag
- = [ HsTypeSig undefined [HsIdent "entityTag"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "ETag"))))
- , HsFunBind [HsMatch undefined (HsIdent "entityTag")
- [] (HsUnGuardedRhs defEntityTag) []]
- ]
-
- defEntityTag :: HsExp
- defEntityTag
- = HsApp (HsVar (UnQual (HsIdent "strongETag")))
- (HsLit (HsString eTag))
-
- declLastModified :: [HsDecl]
- declLastModified
- = [ HsTypeSig undefined [HsIdent "lastModified"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "UTCTime"))))
- , HsFunBind [HsMatch undefined (HsIdent "lastModified")
- [] (HsUnGuardedRhs defLastModified) []]
- ]
-
- defLastModified :: HsExp
- defLastModified
- = HsApp (HsVar (UnQual (HsIdent "read")))
- (HsLit (HsString $ show lastMod))
-
-
- declContentType :: [HsDecl]
- declContentType
- = [ HsTypeSig undefined [HsIdent "contentType"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "MIMEType"))))
- , HsFunBind [HsMatch undefined (HsIdent "contentType")
- [] (HsUnGuardedRhs defContentType) []]
- ]
-
- defContentType :: HsExp
- defContentType
- = HsApp (HsVar (UnQual (HsIdent "read")))
- (HsLit (HsString $ show mimeType))
-
- declGZippedData :: [HsDecl]
- declGZippedData
- = [ HsTypeSig undefined [HsIdent "gzippedData"]
- (HsQualType []
- (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
- , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
- [] (HsUnGuardedRhs defGZippedData) []]
- ]
-
- defGZippedData :: HsExp
- defGZippedData
- = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "fromJust")))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "decode")))
- (HsLit (HsString gzippedB64))))))
-
- declRawData :: [HsDecl]
- declRawData
- = [ HsTypeSig undefined [HsIdent "rawData"]
- (HsQualType []
- (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
- , HsFunBind [HsMatch undefined (HsIdent "rawData")
- [] (HsUnGuardedRhs defRawData) []]
- ]
-
- defRawData :: HsExp
- defRawData
- = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "fromJust")))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "decode")))
- (HsLit (HsString rawB64))))))