Network/HTTP/Lucu/Implant/PrettyPrint.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 module Network.HTTP.Lucu.Implant.PrettyPrint
   9     ( pprInput
  10     )
  11     where
  12 import Codec.Compression.GZip
  13 import Control.Monad
  14 import Data.Ascii (CIAscii)
  15 import qualified Data.Ascii as A
  16 import qualified Data.ByteString.Lazy as L
  17 import Data.List
  18 import qualified Data.Map as M
  19 import Data.Time
  20 import Language.Haskell.TH.Lib
  21 import Language.Haskell.TH.Ppr
  22 import Language.Haskell.TH.PprLib
  23 import Language.Haskell.TH.Syntax
  24 import Network.HTTP.Lucu.ETag
  25 import Network.HTTP.Lucu.Implant.Input
  26 import Network.HTTP.Lucu.Implant.Rewrite
  27 import Network.HTTP.Lucu.MIMEType
  28 import Network.HTTP.Lucu.Resource
  29 import Network.HTTP.Lucu.Utils
  30 import Prelude.Unicode
  31
  32 header ∷ Input → Doc
  33 header i@(Input {..})
  34     = vcat [ text "{- DO NOT EDIT THIS FILE."
  35            , nest 3 $
  36              vcat [ text "This file is automatically generated by lucu-implant-file."
  37                   , text ""
  38                   , text "           Source:" <+> if iPath ≡ "-" then
  39                                                       text "(stdin)"
  40                                                   else
  41                                                       text iPath
  42                   , hsep [ text "  Original Length:"
  43                          , integer (originalLen i)
  44                          , text "bytes"
  45                          ]
  46                   , if useGZip i then
  47                         vcat [ hsep [ text "Compressed Length:"
  48                                     , integer (gzippedLen i)
  49                                     , text "bytes"
  50                                     ]
  51                              , text "      Compression: gzip"
  52                              ]
  53                     else
  54                         text "      Compression: disabled"
  55                   , text "        MIME Type:" <+> mimeTypeToDoc iType
  56                   , text "             ETag:" <+> eTagToDoc iETag
  57                   , text "    Last Modified:" <+> text (show iLastMod)
  58                   ]
  59            , text " -}"
  60            , text "{-# LANGUAGE MagicHash #-}"
  61            ]
  62     where
  63       eTagToDoc ∷ ETag → Doc
  64       eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
  65
  66       mimeTypeToDoc ∷ MIMEType → Doc
  67       mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
  68
  69 moduleDecl ∷ ModName → Name → Doc
  70 moduleDecl modName symName
  71     = hsep [ text "module"
  72            , text (modString modName)
  73            , lparen
  74            , ppr symName
  75            , rparen
  76            , text "where"
  77            ]
  78
  79 importDecls ∷ ModMap → Doc
  80 importDecls = vcat ∘ map f ∘ M.toAscList
  81     where
  82       f ∷ (ModName, Maybe ModName) → Doc
  83       f (m, Nothing) = hsep [ text "import"
  84                             , text (modString m)
  85                             ]
  86       f (m, Just m') = hsep [ text "import"
  87                             , text "qualified"
  88                             , text (modString m)
  89                             , text "as"
  90                             , text (modString m')
  91                             ]
  92
  93 entityTag ∷ Name
  94 entityTag = mkName "entityTag"
  95
  96 lastModified ∷ Name
  97 lastModified = mkName "lastModified"
  98
  99 contentType ∷ Name
 100 contentType = mkName "contentType"
 101
 102 rawData ∷ Name
 103 rawData = mkName "rawData"
 104
 105 gzippedData ∷ Name
 106 gzippedData = mkName "gzippedData"
 107
 108 gzipEncoding ∷ Name
 109 gzipEncoding = mkName "gzipEncoding"
 110
 111 resourceDecl ∷ Input → Name → Q [Dec]
 112 resourceDecl i symName
 113     = sequence [ sigD symName [t| ResourceDef |]
 114                , valD (varP symName) (normalB (resourceE i)) decls
 115                ]
 116     where
 117       decls ∷ [Q Dec]
 118       decls | useGZip i
 119                 = [ sigD gzipEncoding [t| CIAscii |]
 120                   , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
 121                   ]
 122             | otherwise
 123                 = []
 124
 125 resourceE ∷ Input → Q Exp
 126 resourceE i = [| emptyResource {
 127                    resGet  = $(resGetE  i)
 128                  , resHead = $(resHeadE i)
 129                  }
 130                |]
 131
 132 resGetE ∷ Input → Q Exp
 133 resGetE i
 134     | useGZip i
 135         = [| Just $
 136              do foundEntity $(varE entityTag) $(varE lastModified)
 137                 setContentType $(varE contentType)
 138
 139                 gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
 140                 if gzipAllowed then
 141                     do setContentEncoding [$(varE gzipEncoding)]
 142                        putChunks $(varE gzippedData)
 143                 else
 144                     putChunks (decompress $(varE gzippedData))
 145            |]
 146     | otherwise
 147         = [| Just $
 148              do foundEntity $(varE entityTag) $(varE lastModified)
 149                 setContentType $(varE contentType)
 150                 putChunks $(varE rawData)
 151            |]
 152
 153 resHeadE ∷ Input → Q Exp
 154 resHeadE i
 155     | useGZip i
 156         = [| Just $
 157              do foundEntity $(varE entityTag) $(varE lastModified)
 158                 setContentType $(varE contentType)
 159
 160                 gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
 161                 when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
 162            |]
 163     | otherwise
 164         = [| Just $
 165              do foundEntity $(varE entityTag)
 166                             $(varE lastModified)
 167                 setContentType $(varE contentType)
 168            |]
 169
 170 eTagDecl ∷ Input → Q [Dec]
 171 eTagDecl (Input {..})
 172     = sequence [ sigD entityTag [t| ETag |]
 173                , valD (varP entityTag) (normalB (lift iETag)) []
 174                ]
 175
 176 lastModDecl ∷ Input → Q [Dec]
 177 lastModDecl (Input {..})
 178     = sequence [ sigD lastModified [t| UTCTime |]
 179                , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
 180                ]
 181
 182 contTypeDecl ∷ Input → Q [Dec]
 183 contTypeDecl (Input {..})
 184     = sequence [ sigD contentType [t| MIMEType |]
 185                , valD (varP contentType) (normalB (lift iType)) []
 186                ]
 187
 188 binDecl ∷ Input → Q [Dec]
 189 binDecl i@(Input {..})
 190     | useGZip i
 191         = sequence [ sigD gzippedData [t| L.ByteString |]
 192                    , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
 193                    ]
 194     | otherwise
 195         = sequence [ sigD rawData [t| L.ByteString |]
 196                    , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
 197                    ]
 198
 199 pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
 200 pprInput i modName symName
 201     = do decls ← runQ $ sequence [ resourceDecl i symName
 202                                  , eTagDecl i
 203                                  , lastModDecl i
 204                                  , contTypeDecl i
 205                                  , binDecl i
 206                                  ]
 207          let (decls', mods) = rewriteNames decls
 208          return $ vcat [ header i
 209                        , moduleDecl modName symName
 210                        , importDecls mods
 211                        , text ""
 212                        , vcat $ intersperse (text "") $ map ppr decls'
 213                        ]