--- /dev/null
+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , RecordWildCards
+ , TemplateHaskell
+ , UnicodeSyntax
+ #-}
+module Network.HTTP.Lucu.Implant.PrettyPrint
+ ( pprInput
+ )
+ where
+import Codec.Compression.GZip
+import Control.Monad
+import Data.Ascii (CIAscii)
+import qualified Data.Ascii as A
+import qualified Data.ByteString.Lazy as L
+import Data.List
+import qualified Data.Map as M
+import Data.Time
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Ppr
+import Language.Haskell.TH.PprLib
+import Language.Haskell.TH.Syntax
+import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.Implant.Input
+import Network.HTTP.Lucu.Implant.Rewrite
+import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+
+header ∷ Input → Doc
+header i@(Input {..})
+ = vcat [ text "{- DO NOT EDIT THIS FILE."
+ , nest 3 $
+ vcat [ text "This file is automatically generated by lucu-implant-file."
+ , text ""
+ , text " Source:" <+> if iPath ≡ "-" then
+ text "(stdin)"
+ else
+ text iPath
+ , hsep [ text " Original Length:"
+ , integer (originalLen i)
+ , text "bytes"
+ ]
+ , if useGZip i then
+ vcat [ hsep [ text "Compressed Length:"
+ , integer (gzippedLen i)
+ , text "bytes"
+ ]
+ , text " Compression: gzip"
+ ]
+ else
+ text " Compression: disabled"
+ , text " MIME Type:" <+> mimeTypeToDoc iType
+ , text " ETag:" <+> eTagToDoc iETag
+ , text " Last Modified:" <+> text (show iLastMod)
+ ]
+ , text " -}"
+ , text "{-# LANGUAGE MagicHash #-}"
+ ]
+ where
+ eTagToDoc ∷ ETag → Doc
+ eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
+
+ mimeTypeToDoc ∷ MIMEType → Doc
+ mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
+
+moduleDecl ∷ ModName → Name → Doc
+moduleDecl modName symName
+ = hsep [ text "module"
+ , text (modString modName)
+ , lparen
+ , ppr symName
+ , rparen
+ , text "where"
+ ]
+
+importDecls ∷ ModMap → Doc
+importDecls = vcat ∘ map f ∘ M.toAscList
+ where
+ f ∷ (ModName, Maybe ModName) → Doc
+ f (m, Nothing) = hsep [ text "import"
+ , text (modString m)
+ ]
+ f (m, Just m') = hsep [ text "import"
+ , text "qualified"
+ , text (modString m)
+ , text "as"
+ , text (modString m')
+ ]
+
+entityTag ∷ Name
+entityTag = mkName "entityTag"
+
+lastModified ∷ Name
+lastModified = mkName "lastModified"
+
+contentType ∷ Name
+contentType = mkName "contentType"
+
+rawData ∷ Name
+rawData = mkName "rawData"
+
+gzippedData ∷ Name
+gzippedData = mkName "gzippedData"
+
+gzipEncoding ∷ Name
+gzipEncoding = mkName "gzipEncoding"
+
+resourceDecl ∷ Input → Name → Q [Dec]
+resourceDecl i symName
+ = sequence [ sigD symName [t| ResourceDef |]
+ , valD (varP symName) (normalB (resourceE i)) decls
+ ]
+ where
+ decls ∷ [Q Dec]
+ decls | useGZip i
+ = [ sigD gzipEncoding [t| CIAscii |]
+ , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
+ ]
+ | otherwise
+ = []
+
+resourceE ∷ Input → Q Exp
+resourceE i = [| emptyResource {
+ resGet = $(resGetE i)
+ , resHead = $(resHeadE i)
+ }
+ |]
+
+resGetE ∷ Input → Q Exp
+resGetE i
+ | useGZip i
+ = [| Just $
+ do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
+
+ gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
+ if gzipAllowed then
+ do setContentEncoding [$(varE gzipEncoding)]
+ putChunks $(varE gzippedData)
+ else
+ putChunks (decompress $(varE gzippedData))
+ |]
+ | otherwise
+ = [| Just $
+ do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
+ putChunks $(varE rawData)
+ |]
+
+resHeadE ∷ Input → Q Exp
+resHeadE i
+ | useGZip i
+ = [| Just $
+ do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
+
+ gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
+ when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
+ |]
+ | otherwise
+ = [| Just $
+ do foundEntity $(varE entityTag)
+ $(varE lastModified)
+ setContentType $(varE contentType)
+ |]
+
+eTagDecl ∷ Input → Q [Dec]
+eTagDecl (Input {..})
+ = sequence [ sigD entityTag [t| ETag |]
+ , valD (varP entityTag) (normalB (lift iETag)) []
+ ]
+
+lastModDecl ∷ Input → Q [Dec]
+lastModDecl (Input {..})
+ = sequence [ sigD lastModified [t| UTCTime |]
+ , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
+ ]
+
+contTypeDecl ∷ Input → Q [Dec]
+contTypeDecl (Input {..})
+ = sequence [ sigD contentType [t| MIMEType |]
+ , valD (varP contentType) (normalB (lift iType)) []
+ ]
+
+binDecl ∷ Input → Q [Dec]
+binDecl i@(Input {..})
+ | useGZip i
+ = sequence [ sigD gzippedData [t| L.ByteString |]
+ , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
+ ]
+ | otherwise
+ = sequence [ sigD rawData [t| L.ByteString |]
+ , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
+ ]
+
+pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
+pprInput i modName symName
+ = do decls ← runQ $ sequence [ resourceDecl i symName
+ , eTagDecl i
+ , lastModDecl i
+ , contTypeDecl i
+ , binDecl i
+ ]
+ let (decls', mods) = rewriteNames decls
+ return $ vcat [ header i
+ , moduleDecl modName symName
+ , importDecls mods
+ , text ""
+ , vcat $ intersperse (text "") $ map ppr decls'
+ ]
projects / Lucu.git / blobdiff