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
import Network.HTTP.Lucu.Implant.PrettyPrint
import Network.HTTP.Lucu.MIMEType
import Prelude.Unicode
-Name: Lucu
-Synopsis: Embedded HTTP Server
+Name: Lucu
+Synopsis: Embedded HTTP Server
Description:
-
- Lucu is an embedded HTTP server library.
-
- It's not a replacement for Apache nor lighttpd. It is intended
- to be used to build an efficient web-based RESTful application
- which runs behind a reverse-proxy so it doesn't have some
- functionalities like logging, client filtering and such.
-
-Version: 1.0
-License: PublicDomain
-License-File: COPYING
-Author: PHO <pho at cielonegro dot org>
-Maintainer: PHO <pho at cielonegro dot org>
-Stability: experimental
-Homepage: http://cielonegro.org/Lucu.html
-Bug-Reports: http://static.cielonegro.org/ditz/Lucu/
-Category: Network
-Tested-With: GHC == 7.0.3
+ .
+ Lucu is an embedded HTTP server library.
+ .
+ This isn't a replacement for Apache nor lighttpd. It is intended
+ to be used to build an efficient web-based RESTful application
+ which runs behind a reverse-proxy so it doesn't have some
+ functionalities like logging, client filtering and such.
+ .
+ The library has indeed so many exposed modules, but in general
+ you don't need to import any modules other than
+ "Network.HTTP.Lucu".
+ .
+Version: 1.0
+License: PublicDomain
+License-File: COPYING
+Author: PHO <pho at cielonegro dot org>
+Maintainer: PHO <pho at cielonegro dot org>
+Stability: experimental
+Homepage: http://cielonegro.org/Lucu.html
+Bug-Reports: http://static.cielonegro.org/ditz/Lucu/
+Category: Network
+Tested-With: GHC == 7.0.3
Cabal-Version: >= 1.6
-Build-Type: Simple
+Build-Type: Simple
Extra-Source-Files:
NEWS
examples/HelloWorld.hs
Network.HTTP.Lucu.Authentication
Network.HTTP.Lucu.Config
Network.HTTP.Lucu.ETag
+ Network.HTTP.Lucu.HandleLike
+ Network.HTTP.Lucu.Headers
Network.HTTP.Lucu.HttpVersion
Network.HTTP.Lucu.Httpd
+ Network.HTTP.Lucu.Implant
+ Network.HTTP.Lucu.Implant.PrettyPrint
+ Network.HTTP.Lucu.Implant.Rewrite
Network.HTTP.Lucu.MIMEParams
Network.HTTP.Lucu.MIMEType
Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
Network.HTTP.Lucu.Resource
Network.HTTP.Lucu.Resource.Tree
Network.HTTP.Lucu.Response
+ Network.HTTP.Lucu.SocketLike
Network.HTTP.Lucu.StaticFile
Network.HTTP.Lucu.StatusCode
Network.HTTP.Lucu.Utils
Network.HTTP.Lucu.Chunk
Network.HTTP.Lucu.ContentCoding
Network.HTTP.Lucu.DefaultPage
- Network.HTTP.Lucu.HandleLike
- Network.HTTP.Lucu.Headers
Network.HTTP.Lucu.Interaction
Network.HTTP.Lucu.Postprocess
Network.HTTP.Lucu.Preprocess
Network.HTTP.Lucu.RequestReader
Network.HTTP.Lucu.Resource.Internal
Network.HTTP.Lucu.ResponseWriter
- Network.HTTP.Lucu.SocketLike
Network.HTTP.Lucu.StatusCode.Internal
ghc-options:
Main-Is: ImplantFile.hs
- Other-Modules:
- Network.HTTP.Lucu.Implant.Input
- Network.HTTP.Lucu.Implant.PrettyPrint
- Network.HTTP.Lucu.Implant.Rewrite
-
Build-Depends:
SHA == 1.5.*,
syb == 0.3.*,
-- *** MIME Type
, MIMEType(..)
+ , MIMEParams(..)
, parseMIMEType
, mimeType
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ETag
import Network.HTTP.Lucu.Httpd
+import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.MIMEType hiding (mimeType)
import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Resource
OverloadedStrings
, UnicodeSyntax
#-}
--- |HTTP Authentication
+-- |An internal module for HTTP authentication.
module Network.HTTP.Lucu.Authentication
( AuthChallenge(..)
, AuthCredential(..)
, TemplateHaskell
, UnicodeSyntax
#-}
--- |Entity tags
+-- |An internal module for entity tags.
module Network.HTTP.Lucu.ETag
( ETag(..)
, parseETag
DoAndIfThenElse
, UnicodeSyntax
#-}
+-- |Type class for things behaves like a 'I.Handle'.
module Network.HTTP.Lucu.HandleLike
( HandleLike(..)
, hPutBuilder
, OverloadedStrings
, UnicodeSyntax
#-}
+-- |An internal module for HTTP headers.
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
OverloadedStrings
, UnicodeSyntax
#-}
--- |HTTP version number
+-- |An internal module for HTTP version numbers.
module Network.HTTP.Lucu.HttpVersion
( HttpVersion(..)
, printHttpVersion
, RecordWildCards
, UnicodeSyntax
#-}
-module Network.HTTP.Lucu.Implant.Input
+-- |An internal module for generating Haskell modules eith an
+-- arbitrary file implanted.
+module Network.HTTP.Lucu.Implant
( Input(..)
, originalLen
, RecordWildCards
, TemplateHaskell
, UnicodeSyntax
+ , ViewPatterns
#-}
+-- |An internal module for generating Haskell modules eith an
+-- arbitrary file implanted.
module Network.HTTP.Lucu.Implant.PrettyPrint
( pprInput
)
import Data.Ascii (CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString.Lazy as L
+import Data.Char
+import Data.Foldable
import Data.List
-import qualified Data.Map as M
+import Data.Ratio
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
import Network.HTTP.Lucu.Implant.Rewrite
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Resource
moduleDecl ∷ ModName → Name → Doc
moduleDecl modName symName
- = hsep [ text "module"
- , text (modString modName)
- , lparen
- , ppr symName
- , rparen
- , text "where"
- ]
+ = text "module" <+> text (modString modName) $+$
+ nest 4 (vcat [ lparen <+> ppr symName
+ , rparen
+ , text "where"
+ ])
+
+importDecls ∷ Imports ImportOp → Doc
+importDecls = vcat ∘ map pprImport ∘ toList
-importDecls ∷ ModMap → Doc
-importDecls = vcat ∘ map f ∘ M.toAscList
+pprImport ∷ ImportOp → Doc
+pprImport (QualifiedImp {..})
+ = hsep [ text "import"
+ , text "qualified"
+ , text (modString impModule)
+ , text "as"
+ , text (modString impAlias)
+ ]
+pprImport (UnqualifiedImp {impNames = Nothing, ..})
+ = hsep [ text "import"
+ , text (modString impModule)
+ ]
+pprImport (UnqualifiedImp {impNames = Just ns, ..})
+ = hsep [ text "import"
+ , text (modString impModule)
+ , hcat [ lparen
+ , sep $ punctuate comma
+ $ map (uncurry pprImpName)
+ $ toList ns
+ , rparen
+ ]
+ ]
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')
- ]
+ pprImpName ∷ NameSpace → OccName → Doc
+ pprImpName TcClsName (occString → o)
+ = hcat [text o, text "(..)"]
+ pprImpName _ (occString → o)
+ | needParen o = hcat [lparen, text o, rparen]
+ | otherwise = text o
+
+ needParen ∷ String → Bool
+ needParen (head → c)
+ | isPunctuation c = True
+ | isSymbol c = True
+ | otherwise = False
entityTag ∷ Name
entityTag = mkName "entityTag"
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))
+ = [| 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)
+ = [| 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)
+ = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
- gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
- when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
+ gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
+ when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
+ )
|]
| otherwise
- = [| Just $
- do foundEntity $(varE entityTag)
- $(varE lastModified)
- setContentType $(varE contentType)
+ = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
+ )
|]
eTagDecl ∷ Input → Q [Dec]
, valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
]
+rules ∷ Rules
+rules = [ qualifyAll "Codec.Compression.GZip" "G"
+ , unqualify ''CIAscii "Data.Ascii"
+ , qualifyAll "Data.Ascii" "A"
+ , qualifyAll "Data.ByteString.Char8" "B"
+ , qualifyAll "Data.ByteString.Lazy.Internal" "L"
+ , qualifyAll "Data.Map" "M"
+ , qualifyAll "Data.Text" "T"
+ , unqualifyAll "Network.HTTP.Lucu.ETag" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.Resource" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.Resource.Internal" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.MIMEParams" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.MIMEType" "Network.HTTP.Lucu"
+ , unqualify 'when "Control.Monad"
+ , unqualify '(%) "Data.Ratio"
+ , unqualify ''DiffTime "Data.Time"
+ , unqualifyIn 'ModifiedJulianDay ''Day "Data.Time"
+ , unqualifyIn 'UTCTime ''UTCTime "Data.Time"
+ , unqualifyIn 'False ''Bool "Prelude"
+ , unqualifyIn 'Just ''Maybe "Prelude"
+ , unqualify 'fromRational "Prelude"
+ ]
+
pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
pprInput i modName symName
= do decls ← runQ $ sequence [ resourceDecl i symName
, contTypeDecl i
, binDecl i
]
- let (decls', mods) = rewriteNames decls
+ let (decls', mods) = rewriteNames rules decls
return $ vcat [ header i
, moduleDecl modName symName
, importDecls mods
{-# LANGUAGE
- UnicodeSyntax
+ FlexibleInstances
+ , GeneralizedNewtypeDeriving
+ , RecordWildCards
+ , UnicodeSyntax
#-}
+-- |An internal module for rewriting 'Name's in Template Haskell AST.
module Network.HTTP.Lucu.Implant.Rewrite
- ( ModMap
+ ( NamePat(..)
+ , RewriteOp(..)
+
+ , Imports
+ , ImportOp(..)
+
+ , Rules
+ , RewriteRule(..)
+ , qualifyAll
+ , unqualify
+ , unqualifyIn
+ , unqualifyAll
+
, rewriteNames
)
where
import Control.Applicative
import Control.Monad.State
import Data.Data
-import Data.Generics.Aliases
+import Data.Foldable
+import Data.Generics.Aliases hiding (GT)
import Data.Generics.Schemes
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Monoid
import Data.Monoid.Unicode
+import Data.Set (Set)
+import qualified Data.Set as S
import Language.Haskell.TH.Syntax
+import Prelude
import Prelude.Unicode
--- FIXME: Document at least these data types.
-type ModMap = Map ModName (Maybe ModName)
-data RewriteTo = Qual (Maybe ModName) ModName | UnQual (Maybe ModName)
-
-rewriteNames ∷ Data d ⇒ d → (d, ModMap)
-rewriteNames
- = flip runState (∅) ∘ gmapM (everywhereM (mkM rewriteName))
-
-rewriteName ∷ (Functor m, Monad m)
- ⇒ Name
- → StateT ModMap m Name
-rewriteName (Name o fl) = Name o <$> rewriteNameFlavour fl
-
-rewriteNameFlavour ∷ (Functor m, Monad m)
- ⇒ NameFlavour
- → StateT ModMap m NameFlavour
-rewriteNameFlavour fl
- = case getModName fl of
- Nothing → return fl
- Just m → do let r = M.lookup m modules
- insertIntoModMap m r
- return $ setModName r fl
-
-insertIntoModMap ∷ Monad m
- ⇒ ModName
- → Maybe RewriteTo
- → StateT ModMap m ()
-insertIntoModMap _ (Just (Qual (Just m) m')) = modify $ M.insert m (Just m')
-insertIntoModMap m (Just (Qual Nothing m')) = modify $ M.insert m (Just m')
-insertIntoModMap _ (Just (UnQual (Just m) )) = modify $ M.insert m Nothing
-insertIntoModMap _ (Just (UnQual Nothing )) = return ()
-insertIntoModMap m Nothing = modify $ M.insert m Nothing
-
-getModName ∷ NameFlavour → Maybe ModName
-getModName (NameQ m) = Just m
-getModName (NameG _ _ m) = Just m
-getModName _ = Nothing
-
-setModName ∷ Maybe RewriteTo → NameFlavour → NameFlavour
-setModName (Just (Qual _ m)) (NameQ _ ) = NameQ m
-setModName (Just (Qual _ m)) (NameG _ _ _) = NameQ m
-setModName (Just (UnQual _)) (NameQ _ ) = NameS
-setModName (Just (UnQual _)) (NameG _ _ _) = NameS
-setModName Nothing (NameQ _ ) = NameS
-setModName Nothing (NameG _ _ _) = NameS
-setModName _ _ = error "setModName: internal error"
-
-modules ∷ Map ModName RewriteTo
-modules
- = M.fromList
- [ ( mkModName "Codec.Compression.GZip"
- , Qual Nothing $ mkModName "G"
- )
- , ( mkModName "Data.Ascii"
- , Qual Nothing $ mkModName "A"
- )
- , ( mkModName "Data.ByteString.Char8"
- , Qual Nothing $ mkModName "B"
- )
- , ( mkModName "Data.ByteString.Lazy.Internal"
- , Qual Nothing $ mkModName "L"
- )
- , ( mkModName "Data.ByteString.Unsafe"
- , Qual Nothing $ mkModName "B"
- )
- , ( mkModName "Data.Map"
- , Qual Nothing $ mkModName "M"
- )
- , ( mkModName "Data.Maybe"
- , UnQual Nothing
- )
- , ( mkModName "Data.Text"
- , Qual Nothing $ mkModName "T"
- )
- , ( mkModName "Data.Time.Calendar.Days"
- , UnQual $ Just $ mkModName "Data.Time"
- )
- , ( mkModName "Data.Time.Clock.Scale"
- , UnQual $ Just $ mkModName "Data.Time"
- )
- , ( mkModName "Data.Time.Clock.UTC"
- , UnQual $ Just $ mkModName "Data.Time"
- )
- , ( mkModName "GHC.Base"
- , UnQual Nothing
- )
- , ( mkModName "GHC.Bool"
- , UnQual Nothing
- )
- , ( mkModName "GHC.IO"
- -- for 'unsafePerformIO', but rather problematic...
- , UnQual $ Just $ mkModName "System.IO.Unsafe"
- )
- , ( mkModName "GHC.Real"
- -- for '%', but rather problematic...
- , UnQual $ Just $ mkModName "Data.Ratio"
- )
- , ( mkModName "Network.HTTP.Lucu.ETag"
- , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
- )
- , ( mkModName "Network.HTTP.Lucu.MIMEType"
- , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
- )
- , ( mkModName "Network.HTTP.Lucu.Resource"
- , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
- )
- , ( mkModName "Network.HTTP.Lucu.Resource.Internal"
- , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
- )
- ]
+-- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
+-- and 'Nothing' represensts a wildcard.
+data NamePat
+ = NamePat !(Maybe ModName) !(Maybe OccName)
+
+-- |Instruction for rewriting 'Name's.
+data RewriteOp
+ = Identity
+ | Unqualify
+ | Qualify !ModName
+
+-- |A 'Set' of modules and names to be imported.
+newtype Imports α = Imports (Set α)
+ deriving Foldable
+
+-- |Instruction for declaring module imports.
+data ImportOp
+ = -- |> import qualified M as A
+ QualifiedImp {
+ impModule ∷ !ModName
+ , impAlias ∷ !ModName
+ }
+ -- |> import M
+ --
+ -- or
+ --
+ -- > import M (a, b, c, ...)
+ | UnqualifiedImp {
+ impModule ∷ !ModName
+ , impNames ∷ !(Maybe (Set (NameSpace, OccName)))
+ }
+ deriving Eq
+
+-- |List of 'RewriteRule's.
+type Rules = [RewriteRule]
+
+-- |Instruction for rewriting 'Name's and declaring module imports.
+data RewriteRule
+ = RewriteRule {
+ rrPat ∷ !NamePat
+ , rrOp ∷ !RewriteOp
+ , rrImps ∷ !(Imports ImportOp)
+ }
+
+instance Ord ImportOp where
+ α `compare` β
+ | impModule α < impModule β = LT
+ | impModule α > impModule β = GT
+ | otherwise
+ = case (α, β) of
+ (QualifiedImp {}, QualifiedImp {})
+ → impAlias α `compare` impAlias β
+ (QualifiedImp {}, _ )
+ → GT
+ (UnqualifiedImp {}, UnqualifiedImp {})
+ → impNames α `compare` impNames β
+ (UnqualifiedImp {}, _ )
+ → LT
+
+instance Monoid (Imports ImportOp) where
+ mempty
+ = Imports (∅)
+ mappend (Imports α) (Imports β)
+ = Imports (foldl' insertImp α β)
+
+insertImp ∷ Set ImportOp → ImportOp → Set ImportOp
+insertImp α qi@(QualifiedImp {}) = S.insert qi α
+insertImp α ui@(UnqualifiedImp {})
+ = case find sameMod α of
+ Nothing → S.insert ui α
+ Just ui' → S.insert (merge ui') (S.delete ui' α)
+ where
+ sameMod ∷ ImportOp → Bool
+ sameMod ui'@(UnqualifiedImp {})
+ = impModule ui ≡ impModule ui'
+ sameMod _
+ = False
+
+ merge ∷ ImportOp → ImportOp
+ merge ui'
+ = case (impNames ui, impNames ui') of
+ (Nothing, _ ) → ui
+ (_ , Nothing) → ui'
+ (Just s , Just s') → ui { impNames = Just (s ⊕ s') }
+
+-- |@'qualifyAll' module alias@: qualify every symbols defined in
+-- @module@ with @alias@.
+qualifyAll ∷ String → String → RewriteRule
+qualifyAll m a
+ = let pat = NamePat (Just (mkModName m)) Nothing
+ rop = Qualify (mkModName a)
+ iop = QualifiedImp (mkModName m) (mkModName a)
+ in
+ RewriteRule pat rop (Imports (S.singleton iop))
+
+-- |@'unqualify' name module@: unqualify the symbol @name@ with
+-- importing @module@.
+unqualify ∷ Name → String → RewriteRule
+unqualify (Name o _) m
+ = let pat = NamePat Nothing (Just o)
+ iop = UnqualifiedImp (mkModName m)
+ $ Just
+ $ S.singleton (VarName, o)
+ in
+ RewriteRule pat Unqualify (Imports (S.singleton iop))
+
+-- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
+-- name, or whatever resides in the type or class @tycl@ with
+-- importing @module@.
+unqualifyIn ∷ Name → Name → String → RewriteRule
+unqualifyIn (Name name _) (Name tycl _) m
+ = let pat = NamePat Nothing (Just name)
+ iop = UnqualifiedImp (mkModName m)
+ $ Just
+ $ S.singleton (TcClsName, tycl)
+ in
+ RewriteRule pat Unqualify (Imports (S.singleton iop))
+
+-- |@'unqualifyAll' origMod impMod@: unqualify every symbols
+-- defined in @origMod@ with importing @impMod@.
+unqualifyAll ∷ String → String → RewriteRule
+unqualifyAll origMod impMod
+ = let pat = NamePat (Just (mkModName origMod)) Nothing
+ iop = UnqualifiedImp (mkModName impMod) Nothing
+ in
+ RewriteRule pat Unqualify (Imports (S.singleton iop))
+
+-- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
+-- in @d@ according to the name-rewriting @rules@ while at the same
+-- time building a set of modules to be imported.
+rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports ImportOp)
+rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
+ where
+ f ∷ (Functor m, Monad m) ⇒ Name → StateT (Imports ImportOp) m Name
+ f n = case findRule rules n of
+ Nothing → fail $ "No rules matches to name: " ⧺ showName n
+ Just r → applyRule r n
+
+findRule ∷ Rules → Name → Maybe RewriteRule
+findRule _ (Name _ NameS ) = Just identityRule
+findRule rs (Name o (NameQ m)) = find (matchPat m o ∘ rrPat) rs
+findRule _ (Name _ (NameU _ )) = Just identityRule
+findRule rs (Name o (NameG _ _ m)) = find (matchPat m o ∘ rrPat) rs
+findRule _ _ = Nothing
+
+identityRule ∷ RewriteRule
+identityRule = RewriteRule {
+ rrPat = NamePat Nothing Nothing
+ , rrOp = Identity
+ , rrImps = (∅)
+ }
+
+matchPat ∷ ModName → OccName → NamePat → Bool
+matchPat m o (NamePat mp op)
+ = maybe True (≡ m) mp ∧ maybe True (≡ o) op
+
+applyRule ∷ (Functor m, Monad m)
+ ⇒ RewriteRule
+ → Name
+ → StateT (Imports ImportOp) m Name
+applyRule (RewriteRule {..}) n
+ = modify (⊕ rrImps) *> pure (rewrite rrOp n)
+
+rewrite ∷ RewriteOp → Name → Name
+rewrite Identity n = n
+rewrite Unqualify (Name o _) = Name o NameS
+rewrite (Qualify m) (Name o _) = Name o (NameQ m)
#-}
-- |Parse \"multipart/form-data\" based on RFC 2388:
-- <http://tools.ietf.org/html/rfc2388>
---
--- You usually don't have to use this module directly.
module Network.HTTP.Lucu.MultipartForm
( FormData(..)
, parseMultipartFormData
{-# LANGUAGE
UnicodeSyntax
#-}
--- |This is an auxiliary parser utilities. You usually don't have to
--- use this module directly.
+-- |A set of auxiliary parser utilities.
module Network.HTTP.Lucu.Parser
( atMost
, finishOff
, TypeFamilies
, UnicodeSyntax
#-}
+-- |Type class for things behaves like a 'So.Socket'.
module Network.HTTP.Lucu.SocketLike
( SocketLike(..)
)
, TemplateHaskell
, UnicodeSyntax
#-}
--- |Utility functions used internally in the Lucu httpd. These
--- functions may be useful too for something else.
+-- |Utility functions used internally in this package.
module Network.HTTP.Lucu.Utils
( splitBy
, quoteStr
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Strict
-import qualified Data.ByteString.Unsafe as Strict
import qualified Data.ByteString.Lazy.Internal as Lazy
import Data.Char
import Data.List hiding (last)
import Network.URI
import Prelude hiding (last)
import Prelude.Unicode
-import System.IO.Unsafe
-- |>>> splitBy (== ':') "ab:c:def"
-- ["ab", "c", "def"]
-- |Convert an 'Ascii' to an 'Exp' representing it as a literal.
liftAscii ∷ Ascii → Q Exp
-liftAscii a = [| A.unsafeFromByteString
- $ unsafePerformIO
- $ Strict.unsafePackAddressLen $len $ptr
- |]
- where
- bs ∷ Strict.ByteString
- bs = A.toByteString a
-
- len, ptr ∷ Q Exp
- len = lift $ Strict.length bs
- ptr = litE $ stringPrimL $ Strict.unpack bs
+liftAscii a = [| A.unsafeFromByteString $(liftByteString $ A.toByteString a) |]
-- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
liftCIAscii ∷ CIAscii → Q Exp
-- |Convert an 'UTCTime' to an 'Exp' representing it as a literal.
liftUTCTime ∷ UTCTime → Q Exp
liftUTCTime (UTCTime {..})
- = [| UTCTime {
- utctDay = $(liftDay utctDay)
- , utctDayTime = $(liftDiffTime utctDayTime)
- }
- |]
+ = [| UTCTime $(liftDay utctDay) $(liftDiffTime utctDayTime) |]
liftDay ∷ Day → Q Exp
liftDay (ModifiedJulianDay {..})
- = [| ModifiedJulianDay {
- toModifiedJulianDay = $(lift toModifiedJulianDay)
- }
- |]
+ = [| ModifiedJulianDay $(lift toModifiedJulianDay) |]
liftDiffTime ∷ DiffTime → Q Exp
liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |]
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
-disposition:
+status: :closed
+disposition: :fixed
creation_time: 2011-11-07 15:28:34.417982 Z
references: []
- PHO <pho@cielonegro.org>
- created
- ""
+- - 2011-11-11 05:29:34.851297 Z
+ - PHO <pho@cielonegro.org>
+ - closed with disposition fixed
+ - It has now cleaner code than before, but not simple at all. I'm done anyway.
git_branch: template-haskell
DITZ ?= ditz
CONFIGURE_ARGS ?= --disable-optimization
+HADDOCK_OPTS ?= --hyperlink-source
HLINT_OPTS ?= --cross --report=dist/report.html
SETUP_FILE := $(wildcard Setup.*hs)
clean-hook:
doc: setup-config
- ./Setup haddock
+ ./Setup haddock $(HADDOCK_OPTS)
install: build
$(SUDO) ./Setup install
ImplantedSmall.hs: dist/SmallFile.hs
dist/SmallFile.hs: small-file.txt $(IMPLANT)
mkdir -p dist
- $(IMPLANT) -m SmallFile -o $@ $<
+ $(IMPLANT) -m SmallFile -t "text/plain; charset=\"UTF-8\"" -o $@ $<
.PHONY: build run clean
projects / Lucu.git / commitdiff