From bb121f1189d01b5089aa5c29f0d390fad36ade48 Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 15 Nov 2011 16:33:03 +0900 Subject: [PATCH] MIMEParams is now an instance of collections-api's type classes. Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- Lucu.cabal | 2 +- Network/HTTP/Lucu.hs | 2 +- Network/HTTP/Lucu/ETag.hs | 7 +- Network/HTTP/Lucu/Headers.hs | 10 +- Network/HTTP/Lucu/Implant/PrettyPrint.hs | 10 +- Network/HTTP/Lucu/Implant/Rewrite.hs | 2 +- Network/HTTP/Lucu/MIMEParams.hs | 159 ++++++++++++++++------- Network/HTTP/Lucu/MIMEType.hs | 6 +- Network/HTTP/Lucu/MIMEType/Guess.hs | 5 +- Network/HTTP/Lucu/MultipartForm.hs | 19 ++- Network/HTTP/Lucu/OrphanInstances.hs | 68 ++++++++++ Network/HTTP/Lucu/RequestReader.hs | 2 +- Network/HTTP/Lucu/Resource.hs | 10 +- Network/HTTP/Lucu/Resource/Tree.hs | 1 - Network/HTTP/Lucu/Utils.hs | 115 ++++++---------- 15 files changed, 256 insertions(+), 162 deletions(-) create mode 100644 Network/HTTP/Lucu/OrphanInstances.hs diff --git a/Lucu.cabal b/Lucu.cabal index 1c71aa8..bdc0b71 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -61,7 +61,6 @@ Library collections-api == 1.0.*, collections-base-instances == 1.0.*, containers == 0.4.*, - containers-unicode-symbols == 0.3.*, directory == 1.1.*, filepath == 1.2.*, hxt == 9.1.*, @@ -120,6 +119,7 @@ Library Network.HTTP.Lucu.ContentCoding Network.HTTP.Lucu.DefaultPage Network.HTTP.Lucu.Interaction + Network.HTTP.Lucu.OrphanInstances Network.HTTP.Lucu.Postprocess Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 682e91f..5a1a950 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -57,7 +57,7 @@ module Network.HTTP.Lucu -- *** MIME Type , MIMEType(..) - , MIMEParams(..) + , MIMEParams , parseMIMEType , mimeType diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index 1335738..08c1060 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -25,6 +25,7 @@ import Data.Attoparsec.Char8 import Data.Data import Data.Monoid.Unicode import Language.Haskell.TH.Syntax +import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http hiding (token) import Network.HTTP.Lucu.Utils @@ -32,8 +33,8 @@ import Prelude.Unicode -- |An entity tag consists of a weakness flag and an opaque string. data ETag = ETag { - -- |The weakness flag. Weak tags looks like W\/\"blahblah\" and - -- strong tags are like \"blahblah\". See: + -- |The weakness flag. Weak tags looks like @W\/\"blahblah\"@ + -- and strong tags are like @\"blahblah\"@. See: -- etagIsWeak ∷ !Bool -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~) @@ -45,7 +46,7 @@ instance Lift ETag where lift (ETag {..}) = [| ETag { etagIsWeak = $(lift etagIsWeak) - , etagToken = $(liftAscii etagToken) + , etagToken = $(lift etagToken ) } |] diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 2ee9cbb..97a7603 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -23,7 +23,7 @@ import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import Data.List (intersperse) -import qualified Data.Map as M +import qualified Data.Map as M (Map) import Data.Collections import Data.Collections.BaseInstances () import Data.Monoid @@ -77,8 +77,8 @@ instance Unfoldable Headers (CIAscii, Ascii) where empty = Headers empty {-# INLINE singleton #-} - singleton v - = Headers $ singleton v + singleton p + = Headers $ singleton p {-# INLINE insertMany #-} insertMany f (Headers m) = Headers $ insertMany f m @@ -87,6 +87,10 @@ instance Unfoldable Headers (CIAscii, Ascii) where = Headers $ insertManySorted f m instance Foldable Headers (CIAscii, Ascii) where + {-# INLINE null #-} + null (Headers m) = null m + {-# INLINE size #-} + size (Headers m) = size m {-# INLINE foldr #-} foldr f b (Headers m) = foldr f b m diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index 85af3cb..fa842a1 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -30,8 +30,8 @@ import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.Implant import Network.HTTP.Lucu.Implant.Rewrite import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Resource -import Network.HTTP.Lucu.Utils import Prelude hiding (head) import Prelude.Unicode @@ -146,7 +146,7 @@ resourceDecl i symName decls ∷ [Q Dec] decls | useGZip i = [ sigD gzipEncoding [t| CIAscii |] - , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) [] + , valD (varP gzipEncoding) (normalB (lift ("gzip" ∷ CIAscii))) [] ] | otherwise = [] @@ -204,7 +204,7 @@ eTagDecl (Input {..}) lastModDecl ∷ Input → Q [Dec] lastModDecl (Input {..}) = sequence [ sigD lastModified [t| UTCTime |] - , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) [] + , valD (varP lastModified) (normalB (lift iLastMod)) [] ] contTypeDecl ∷ Input → Q [Dec] @@ -217,11 +217,11 @@ binDecl ∷ Input → Q [Dec] binDecl i@(Input {..}) | useGZip i = sequence [ sigD gzippedData [t| L.ByteString |] - , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) [] + , valD (varP gzippedData) (normalB (lift iGZipped)) [] ] | otherwise = sequence [ sigD rawData [t| L.ByteString |] - , valD (varP rawData) (normalB (liftLazyByteString iRawData)) [] + , valD (varP rawData) (normalB (lift iRawData)) [] ] rules ∷ Rules diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs index 69b8aee..9abf628 100644 --- a/Network/HTTP/Lucu/Implant/Rewrite.hs +++ b/Network/HTTP/Lucu/Implant/Rewrite.hs @@ -33,7 +33,7 @@ import Data.Generics.Aliases hiding (GT) import Data.Generics.Schemes import Data.Monoid import Data.Monoid.Unicode -import qualified Data.Set as S +import qualified Data.Set as S (Set) import Language.Haskell.TH.Syntax import Prelude hiding (filter, foldr, lookup) import Prelude.Unicode diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 9e5b938..f4b503e 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -1,22 +1,25 @@ {-# LANGUAGE - CPP - , DeriveDataTypeable + DeriveDataTypeable , DoAndIfThenElse + , FlexibleInstances , GeneralizedNewtypeDeriving + , MultiParamTypeClasses , OverloadedStrings , RecordWildCards , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |Parsing and printing MIME parameter values -- (). module Network.HTTP.Lucu.MIMEParams - ( MIMEParams(..) + ( MIMEParams , printMIMEParams , mimeParams ) where -import Control.Applicative +import Control.Applicative hiding (empty) +import Control.Arrow import Control.Monad hiding (mapM) import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) @@ -25,52 +28,106 @@ import Data.Attoparsec.Char8 as P import Data.Bits import qualified Data.ByteString.Char8 as BS import Data.Char -import Data.Data -import Data.Foldable -import Data.Map (Map) -import qualified Data.Map as M +import Data.Collections +import Data.Collections.BaseInstances () +import qualified Data.Map as M (Map) import Data.Monoid import Data.Monoid.Unicode -import Data.Sequence (Seq, ViewL(..)) -import qualified Data.Sequence as S -import Data.Sequence.Unicode hiding ((∅)) +import Data.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding import Data.Text.Encoding.Error -import Data.Traversable +import Data.Typeable import Data.Word import Language.Haskell.TH.Syntax +import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils -import Prelude hiding (concat, mapM, takeWhile) +import Prelude hiding (concat, filter, foldr, lookup, mapM, null, takeWhile) import Prelude.Unicode -- |A 'Map' from MIME parameter attributes to values. Attributes are -- always case-insensitive according to RFC 2045 -- (). newtype MIMEParams - = MIMEParams (Map CIAscii Text) + = MIMEParams (M.Map CIAscii Text) deriving (Eq, Show, Read, Monoid, Typeable) instance Lift MIMEParams where - lift (MIMEParams m) = [| MIMEParams $(liftParams m) |] - where - liftParams ∷ Map CIAscii Text → Q Exp - liftParams = liftMap liftCIAscii liftText + lift (MIMEParams m) = [| MIMEParams $(lift m) |] + +instance Unfoldable MIMEParams (CIAscii, Text) where + {-# INLINE insert #-} + insert p (MIMEParams m) + = MIMEParams $ insert p m + {-# INLINE empty #-} + empty + = MIMEParams empty + {-# INLINE singleton #-} + singleton p + = MIMEParams $ singleton p + {-# INLINE insertMany #-} + insertMany f (MIMEParams m) + = MIMEParams $ insertMany f m + {-# INLINE insertManySorted #-} + insertManySorted f (MIMEParams m) + = MIMEParams $ insertManySorted f m + +instance Foldable MIMEParams (CIAscii, Text) where + {-# INLINE null #-} + null (MIMEParams m) = null m + {-# INLINE size #-} + size (MIMEParams m) = size m + {-# INLINE foldr #-} + foldr f b (MIMEParams m) = foldr f b m + +instance Collection MIMEParams (CIAscii, Text) where + {-# INLINE filter #-} + filter f (MIMEParams m) = MIMEParams $ filter f m + +instance Indexed MIMEParams CIAscii Text where + {-# INLINE index #-} + index k (MIMEParams m) = index k m + {-# INLINE adjust #-} + adjust f k (MIMEParams m) = MIMEParams $ adjust f k m + {-# INLINE inDomain #-} + inDomain k (MIMEParams m) = inDomain k m + +instance Map MIMEParams CIAscii Text where + {-# INLINE lookup #-} + lookup k (MIMEParams m) = lookup k m + {-# INLINE mapWithKey #-} + mapWithKey f (MIMEParams m) + = MIMEParams $ mapWithKey f m + {-# INLINE unionWith #-} + unionWith f (MIMEParams α) (MIMEParams β) + = MIMEParams $ unionWith f α β + {-# INLINE intersectionWith #-} + intersectionWith f (MIMEParams α) (MIMEParams β) + = MIMEParams $ intersectionWith f α β + {-# INLINE differenceWith #-} + differenceWith f (MIMEParams α) (MIMEParams β) + = MIMEParams $ differenceWith f α β + {-# INLINE isSubmapBy #-} + isSubmapBy f (MIMEParams α) (MIMEParams β) + = isSubmapBy f α β + {-# INLINE isProperSubmapBy #-} + isProperSubmapBy f (MIMEParams α) (MIMEParams β) + = isProperSubmapBy f α β + +instance SortingCollection MIMEParams (CIAscii, Text) where + {-# INLINE minView #-} + minView (MIMEParams m) = second MIMEParams <$> minView m -- |Convert MIME parameter values to an 'AsciiBuilder'. printMIMEParams ∷ MIMEParams → AsciiBuilder {-# INLINEABLE printMIMEParams #-} -#if MIN_VERSION_containers(0, 4, 1) -printMIMEParams (MIMEParams m) = M.foldlWithKey' f (∅) m -#else -printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m -#endif +printMIMEParams = foldl' f (∅) where - f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder + f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder {-# INLINE f #-} - f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v + f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v printPair ∷ CIAscii → Text → AsciiBuilder {-# INLINEABLE printPair #-} @@ -224,30 +281,32 @@ rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%') decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams {-# INLINE decodeParams #-} -decodeParams = (MIMEParams <$>) ∘ (mapM decodeSections =≪) ∘ sortBySection +decodeParams = (MIMEParams <$>) + ∘ (mapM (\(k, v) → ((,) k) <$> decodeSections v) =≪) + ∘ sortBySection sortBySection ∷ Monad m ⇒ [ExtendedParam] - → m (Map CIAscii (Map Integer ExtendedParam)) + → m (M.Map CIAscii (M.Map Integer ExtendedParam)) sortBySection = flip go (∅) where go ∷ Monad m ⇒ [ExtendedParam] - → Map CIAscii (Map Integer ExtendedParam) - → m (Map CIAscii (Map Integer ExtendedParam)) + → M.Map CIAscii (M.Map Integer ExtendedParam) + → m (M.Map CIAscii (M.Map Integer ExtendedParam)) go [] m = return m go (x:xs) m - = case M.lookup (epName x) m of + = case lookup (epName x) m of Nothing - → let s = M.singleton (section x) x - m' = M.insert (epName x) s m + → let s = singleton (section x, x) + m' = insert (epName x, s) m in go xs m' Just s - → case M.lookup (section x) s of + → case lookup (section x) s of Nothing - → let s' = M.insert (section x) x s - m' = M.insert (epName x) s' m + → let s' = insert (section x, x ) s + m' = insert (epName x, s') m in go xs m' Just _ @@ -258,16 +317,16 @@ sortBySection = flip go (∅) , "'" ]) -decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text +decodeSections ∷ Monad m ⇒ M.Map Integer ExtendedParam → m Text decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) where toSeq ∷ Monad m - ⇒ Map Integer ExtendedParam + ⇒ M.Map Integer ExtendedParam → Integer → Seq ExtendedParam → m (Seq ExtendedParam) toSeq m expectedSect sects - = case M.minViewWithKey m of + = case minView m of Nothing → return sects Just ((sect, p), m') @@ -283,19 +342,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text decodeSeq sects - = case S.viewl sects of - EmptyL + = case front sects of + Nothing → fail "decodeSeq: internal error: empty seq" - InitialEncodedParam {..} :< xs + Just (InitialEncodedParam {..}, xs) → do d ← getDecoder epCharset t ← decodeStr d epPayload - decodeSeq' (Just d) xs $ S.singleton t - ContinuedEncodedParam {..} :< _ + decodeSeq' (Just d) xs $ singleton t + Just (ContinuedEncodedParam {..}, _) → fail "decodeSeq: internal error: CEP at section 0" - AsciiParam {..} :< xs + Just (AsciiParam {..}, xs) → let t = A.toText apPayload in - decodeSeq' Nothing xs $ S.singleton t + decodeSeq' Nothing xs $ singleton t decodeSeq' ∷ Monad m ⇒ Maybe Decoder @@ -303,12 +362,12 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) → Seq Text → m Text decodeSeq' decoder sects chunks - = case S.viewl sects of - EmptyL + = case front sects of + Nothing → return $ T.concat $ toList chunks - InitialEncodedParam {..} :< _ + Just (InitialEncodedParam {}, _) → fail "decodeSeq': internal error: IEP at section > 0" - ContinuedEncodedParam {..} :< xs + Just (ContinuedEncodedParam {..}, xs) → case decoder of Just d → do t ← decodeStr d epPayload @@ -320,7 +379,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) , A.toString $ A.fromCIAscii epName , "' is encoded but its first section is not" ]) - AsciiParam {..} :< xs + Just (AsciiParam {..}, xs) → let t = A.toText apPayload in decodeSeq' decoder xs $ chunks ⊳ t diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 88bd5e7..2861d26 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -25,9 +25,9 @@ import Data.Monoid.Unicode import Data.Typeable import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.MIMEParams +import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils import Prelude.Unicode -- |A media type, subtype, and parameters. @@ -42,8 +42,8 @@ data MIMEType instance Lift MIMEType where lift (MIMEType {..}) = [| MIMEType { - mtMedia = $(liftCIAscii mtMedia) - , mtSub = $(liftCIAscii mtSub) + mtMedia = $(lift mtMedia ) + , mtSub = $(lift mtSub ) , mtParams = $(lift mtParams) } |] diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index edf1772..7c3c64d 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -32,8 +32,8 @@ import Data.Text.Encoding import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Utils import Prelude.Unicode import System.FilePath @@ -43,8 +43,7 @@ newtype ExtMap deriving (Eq, Show, Read, Monoid, Typeable) instance Lift ExtMap where - lift (ExtMap m) - = [| ExtMap $(liftMap liftText lift m) |] + lift (ExtMap m) = [| ExtMap $(lift m) |] -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@. -- diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 1550030..a5280c0 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -17,7 +17,7 @@ module Network.HTTP.Lucu.MultipartForm where import Control.Applicative hiding (many) import Control.Applicative.Unicode hiding ((∅)) -import Control.Monad.Error +import Control.Monad.Error (MonadError, throwError) import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A @@ -26,13 +26,11 @@ import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LS import Data.ByteString.Lazy.Search -import Data.Foldable -import Data.List -import qualified Data.Map as M +import Data.Collections +import Data.List (intercalate) import Data.Maybe import Data.Monoid.Unicode import Data.Sequence (Seq) -import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Lucu.Headers @@ -42,6 +40,8 @@ import qualified Network.HTTP.Lucu.MIMEType as MT import Network.HTTP.Lucu.MIMEType.TH import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import Prelude hiding (lookup, mapM) import Prelude.Unicode -- |'FormData' represents a form value and possibly an uploaded file @@ -229,7 +229,7 @@ partToFormPair pt@(Part {..}) partName ∷ MonadError String m ⇒ Part → m Ascii {-# INLINEABLE partName #-} partName (Part {..}) - = case M.lookup "name" params of + = case lookup "name" $ dParams ptContDispo of Just name → case A.fromText name of Just a → return a @@ -238,10 +238,7 @@ partName (Part {..}) Nothing → throwError $ "form-data without name: " ⧺ A.toString (printContDispo ptContDispo) - where - params = case dParams ptContDispo of - MIMEParams m → m partFileName ∷ Part → Maybe Text -partFileName (dParams ∘ ptContDispo → MIMEParams m) - = M.lookup "filename" m +partFileName (ptContDispo → ContDispo {..}) + = lookup "filename" dParams diff --git a/Network/HTTP/Lucu/OrphanInstances.hs b/Network/HTTP/Lucu/OrphanInstances.hs new file mode 100644 index 0000000..a7e7b7e --- /dev/null +++ b/Network/HTTP/Lucu/OrphanInstances.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE + RecordWildCards + , TemplateHaskell + , UnicodeSyntax + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.HTTP.Lucu.OrphanInstances + ( + ) + where +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as Strict +import qualified Data.ByteString.Lazy.Internal as Lazy +import Data.CaseInsensitive (CI, FoldCase) +import qualified Data.CaseInsensitive as CI +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ratio +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax +import Prelude hiding (last, mapM, null, reverse) +import Prelude.Unicode + +instance Lift ByteString where + lift bs = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |] + +instance Lift Lazy.ByteString where + lift = Lazy.foldrChunks f [| Lazy.Empty |] + where + f ∷ ByteString → Q Exp → Q Exp + f bs e = [| Lazy.Chunk $(lift bs) $e |] + +instance Lift Ascii where + lift a = [| A.unsafeFromByteString $(lift $ A.toByteString a) |] + +instance (Lift s, FoldCase s) ⇒ Lift (CI s) where + lift s = [| CI.mk $(lift $ CI.original s) |] + +instance Lift Text where + lift t = [| T.pack $(litE $ stringL $ T.unpack t) |] + +instance (Lift k, Lift v) ⇒ Lift (Map k v) where + lift m + | M.null m = [| M.empty |] + | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |] + where + liftPairs = listE ∘ map liftPair + liftPair (k, v) = tupE [lift k, lift v] + +instance Lift UTCTime where + lift (UTCTime {..}) + = [| UTCTime $(lift utctDay) $(lift utctDayTime) |] + +instance Lift Day where + lift (ModifiedJulianDay {..}) + = [| ModifiedJulianDay $(lift toModifiedJulianDay) |] + +instance Lift DiffTime where + lift dt = [| fromRational ($n % $d) ∷ DiffTime |] + where + n, d ∷ Q Exp + n = lift $ numerator $ toRational dt + d = lift $ denominator $ toRational dt diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 5ef7acc..ab70998 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -21,7 +21,6 @@ import Data.List import Data.Maybe import Data.Monoid.Unicode import qualified Data.Sequence as S -import Data.Sequence.Unicode hiding ((∅)) import qualified Data.Text as T import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config @@ -33,6 +32,7 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Resource.Tree +import Network.HTTP.Lucu.Utils import Network.Socket import Prelude.Unicode import System.IO (hPutStrLn, stderr) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index ec3447e..4cf43e0 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -155,8 +155,8 @@ import qualified Data.Attoparsec.Char8 as P import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import Data.List -import qualified Data.Map as M +import Data.Collections +import Data.List (intersperse, sort) import Data.Maybe import Data.Monoid import Data.Monoid.Unicode @@ -177,13 +177,13 @@ import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.MIMEType (MIMEType(..)) import qualified Network.HTTP.Lucu.MIMEType as MT import Network.HTTP.Lucu.MIMEType.TH import Network.HTTP.Lucu.Utils import Network.Socket hiding (accept) import Network.URI hiding (path) +import Prelude hiding (any, drop, lookup, reverse) import Prelude.Unicode -- |Get the string representation of the address of remote host. If @@ -598,8 +598,8 @@ getForm limit Just a → return a Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded" - readMultipartFormData (MIMEParams m) - = case M.lookup "boundary" m of + readMultipartFormData m + = case lookup "boundary" m of Nothing → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data" Just boundary diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index f3fca16..9434cfb 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -25,7 +25,6 @@ import Data.Map (Map) import Data.Maybe import Data.Monoid.Unicode import Data.Sequence (Seq) -import Data.Sequence.Unicode hiding ((∅)) import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Utils import Network.URI hiding (path) diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index c07c9c9..8722ecb 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,7 +1,6 @@ {-# LANGUAGE - OverloadedStrings - , RecordWildCards - , TemplateHaskell + FlexibleContexts + , OverloadedStrings , UnicodeSyntax #-} -- |Utility functions used internally in this package. @@ -12,38 +11,29 @@ module Network.HTTP.Lucu.Utils , splitPathInfo , trim - , getLastModified + , (⊲) + , (⊳) + , (⋈) + , mapM - , liftByteString - , liftLazyByteString - , liftAscii - , liftCIAscii - , liftText - , liftMap - , liftUTCTime + , getLastModified ) where -import Control.Applicative -import Control.Monad -import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import Control.Applicative hiding (empty) +import Control.Monad hiding (mapM) +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Strict -import qualified Data.ByteString.Lazy.Internal as Lazy import Data.Char -import Data.List hiding (last) -import Data.Map (Map) -import qualified Data.Map as M +import Data.Collections +import Data.Collections.BaseInstances () import Data.Monoid.Unicode import Data.Ratio -import Data.Text (Text) -import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax import Network.URI -import Prelude hiding (last) +import Prelude hiding (last, mapM, null, reverse) import Prelude.Unicode import System.Directory import System.Time (ClockTime(..)) @@ -118,6 +108,34 @@ trim = reverse ∘ f ∘ reverse ∘ f where f = dropWhile isSpace +infixr 5 ⊲ +-- | (B2;) = ('<|') +-- +-- U+22B2, NORMAL SUBGROUP OF +(⊲) ∷ Sequence α a ⇒ a → α → α +(⊲) = (<|) + +infixl 5 ⊳ +-- | (B3;) = ('|>') +-- +-- U+22B3, CONTAINS AS NORMAL SUBGROUP +(⊳) ∷ Sequence α a ⇒ α → a → α +(⊳) = (|>) + +infixr 5 ⋈ +-- | (C8;) = ('><') +-- +-- U+22C8, BOWTIE +(⋈) ∷ Sequence α a ⇒ α → α → α +(⋈) = (><) + +-- |Generalised @mapM@ from any 'Foldable' to 'Unfoldable'. Why isn't +-- this in the @collections-api@? +mapM ∷ (Foldable α a, Unfoldable β b, Functor m, Monad m) + ⇒ (a → m b) → α → m β +{-# INLINE mapM #-} +mapM = flip foldrM empty ∘ (flip ((<$>) ∘ flip insert) ∘) + -- |Get the modification time of a given file. getLastModified ∷ FilePath → IO UTCTime getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime @@ -127,54 +145,3 @@ getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime = posixSecondsToUTCTime $ fromRational $ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000) - --- |Convert a 'ByteString' to an 'Exp' representing it as a literal. -liftByteString ∷ ByteString → Q Exp -liftByteString bs - = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |] - --- |Convert a 'Lazy.ByteString' to an 'Exp' representing it as a --- literal. -liftLazyByteString ∷ Lazy.ByteString → Q Exp -liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |] - where - f ∷ ByteString → Q Exp → Q Exp - f bs e = [| Lazy.Chunk $(liftByteString bs) $e |] - --- |Convert an 'Ascii' to an 'Exp' representing it as a literal. -liftAscii ∷ Ascii → Q Exp -liftAscii a = [| A.unsafeFromByteString $(liftByteString $ A.toByteString a) |] - --- |Convert a 'CIAscii' to an 'Exp' representing it as a literal. -liftCIAscii ∷ CIAscii → Q Exp -liftCIAscii a = [| A.toCIAscii $(liftAscii $ A.fromCIAscii a) |] - --- |Convert a 'Text' to an 'Exp' representing it as a literal. -liftText ∷ Text → Q Exp -liftText t = [| T.pack $(litE $ stringL $ T.unpack t) |] - --- |Convert an arbitrary 'Map' to an 'Exp' representing it as a --- literal, using a given key lifter and a value lifter. -liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp -liftMap liftK liftV m - | M.null m = [| M.empty |] - | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |] - where - liftPairs = listE ∘ map liftPair - liftPair (k, v) = tupE [liftK k, liftV v] - --- |Convert an 'UTCTime' to an 'Exp' representing it as a literal. -liftUTCTime ∷ UTCTime → Q Exp -liftUTCTime (UTCTime {..}) - = [| UTCTime $(liftDay utctDay) $(liftDiffTime utctDayTime) |] - -liftDay ∷ Day → Q Exp -liftDay (ModifiedJulianDay {..}) - = [| ModifiedJulianDay $(lift toModifiedJulianDay) |] - -liftDiffTime ∷ DiffTime → Q Exp -liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |] - where - n, d ∷ Q Exp - n = lift $ numerator $ toRational dt - d = lift $ denominator $ toRational dt -- 2.40.0