From ac2ff93f647d60d43ca3cc54eb776fe0f701ac9e Mon Sep 17 00:00:00 2001 From: PHO Date: Fri, 14 Oct 2011 01:47:53 +0900 Subject: [PATCH] Examples now compile. Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- ImplantFile.hs | 71 +++++++++++++++++++---------------- Network/HTTP/Lucu.hs | 1 + Network/HTTP/Lucu/ETag.hs | 23 ++++++++---- Network/HTTP/Lucu/MIMEType.hs | 29 ++++++++++---- examples/Multipart.hs | 56 ++++++++++++++------------- examples/SSL.hs | 68 ++++++++++++++++----------------- 6 files changed, 136 insertions(+), 112 deletions(-) diff --git a/ImplantFile.hs b/ImplantFile.hs index 3b80e60..b085a98 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -182,21 +182,19 @@ resourceDecl symName useGZip resHead ∷ Exp resHead - = infixApp (var $ name "Just") - (op $ name "$" ) - (doE [ foundEntityStmt - , setContentTypeStmt - ]) + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + ]) resGetGZipped ∷ Exp resGetGZipped - = infixApp (var $ name "Just") - (op $ name "$" ) - (doE [ foundEntityStmt - , setContentTypeStmt - , bindGZipStmt - , conditionalOutputStmt - ]) + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + , bindGZipStmt + , conditionalOutputStmt + ]) where condVarName ∷ Name condVarName = name "gzipAllowed" @@ -208,7 +206,7 @@ resGetGZipped bindGZipStmt = genStmt (⊥) (pvar condVarName) - (metaFunction "isEncodingAcceptable" [strE "gzip"]) + (function "isEncodingAcceptable" `app` strE "gzip") conditionalOutputStmt ∷ Stmt conditionalOutputStmt @@ -217,23 +215,26 @@ resGetGZipped (doE [ setContentEncodingGZipStmt , outputStmt (var dataVarName) ]) - (metaFunction "output" - [paren (metaFunction "decompress" [var dataVarName])]) + ( function "output" + `app` + paren (function "decompress" `app` var dataVarName) + ) resGetRaw ∷ Exp resGetRaw - = infixApp (var $ name "Just") - (op $ name "$" ) - (doE [ foundEntityStmt - , setContentTypeStmt - , outputStmt (var $ name "rawData") - ]) + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + , outputStmt (var $ name "rawData") + ]) setContentEncodingGZipStmt ∷ Stmt setContentEncodingGZipStmt - = qualStmt $ - metaFunction "setContentEncoding" - [ listE [ strE "gzip" ] ] + = qualStmt + ( function "setContentEncoding" + `app` + listE [ strE "gzip" ] + ) foundEntityStmt ∷ Stmt foundEntityStmt @@ -245,14 +246,15 @@ foundEntityStmt setContentTypeStmt ∷ Stmt setContentTypeStmt - = qualStmt $ - metaFunction "setContentType" - [var $ name "contentType"] + = qualStmt + ( function "setContentType" + `app` + var (name "contentType") + ) outputStmt ∷ Exp → Stmt outputStmt e - = qualStmt $ - metaFunction "output" [e] + = qualStmt $ function "output" `app` e entityTagDecl ∷ ETag → [Decl] entityTagDecl eTag @@ -264,7 +266,7 @@ entityTagDecl eTag varName = name "entityTag" valExp ∷ Exp - valExp = metaFunction "parseETag" [strE $ eTagToString eTag] + valExp = function "parseETag" `app` strE (eTagToString eTag) lastModifiedDecl ∷ UTCTime → [Decl] lastModifiedDecl lastMod @@ -276,7 +278,7 @@ lastModifiedDecl lastMod varName = name "lastModified" valExp ∷ Exp - valExp = metaFunction "read" [strE $ show lastMod] + valExp = function "read" `app` strE (show lastMod) contentTypeDecl ∷ MIMEType → [Decl] contentTypeDecl mime @@ -288,7 +290,7 @@ contentTypeDecl mime varName = name "contentType" valExp ∷ Exp - valExp = metaFunction "parseMIMEType" [strE $ mimeToString mime] + valExp = function "parseMIMEType" `app` strE (mimeToString mime) mimeToString ∷ MIMEType → String mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType @@ -328,7 +330,7 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod " Compression: gzip\n" else " Compression: disabled\n" - , " MIME Type: ", show mimeType, "\n" + , " MIME Type: ", mimeTypeToString mimeType, "\n" , " ETag: ", eTagToString eTag, "\n" , " Last Modified: ", show localLastMod, "\n" , " -}" @@ -337,6 +339,9 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod eTagToString ∷ ETag → String eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag +mimeTypeToString ∷ MIMEType → String +mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType + getModuleName ∷ [CmdOpt] → IO ModuleName getModuleName opts = case modNameOpts of diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 79b7414..aafaf73 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -67,6 +67,7 @@ module Network.HTTP.Lucu -- *** MIME Type , MIMEType(..) + , mkMIMEType , parseMIMEType -- *** Authorization diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index 9bfa9aa..f7ef838 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -36,6 +36,7 @@ data ETag = ETag { -- |Convert an 'ETag' to 'AsciiBuilder'. printETag ∷ ETag → AsciiBuilder +{-# INLINEABLE printETag #-} printETag et = ( if etagIsWeak et then A.toAsciiBuilder "W/" @@ -48,32 +49,38 @@ printETag et -- |Parse 'Etag' from an 'Ascii'. This functions throws an exception -- for parse error. parseETag ∷ Ascii → ETag +{-# INLINEABLE parseETag #-} parseETag str - = let p = do et ← eTagP - endOfInput - return et - bs = A.toByteString str - in - case parseOnly p bs of - Right et → et - Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err) + = case parseOnly p $ A.toByteString str of + Right et → et + Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err) + where + p ∷ Parser ETag + {-# INLINE p #-} + p = do et ← eTagP + endOfInput + return et -- |This is equivalent to @'ETag' 'Prelude.False'@. If you want to -- generate an ETag from a file, try using -- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'. strongETag ∷ Ascii → ETag +{-# INLINE strongETag #-} strongETag = ETag False -- |This is equivalent to @'ETag' 'Prelude.True'@. weakETag ∷ Ascii → ETag +{-# INLINE weakETag #-} weakETag = ETag True eTagP ∷ Parser ETag +{-# INLINEABLE eTagP #-} eTagP = do isWeak ← option False (string "W/" *> return True) str ← quotedStr return $ ETag isWeak str eTagListP ∷ Parser [ETag] +{-# INLINEABLE eTagListP #-} eTagListP = do xs ← listOf eTagP when (null xs) $ fail "empty list of ETags" diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index acd76b6..fdc112c 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -6,6 +6,8 @@ -- |Manipulation of MIME Types. module Network.HTTP.Lucu.MIMEType ( MIMEType(..) + , mkMIMEType + , parseMIMEType , printMIMEType @@ -33,8 +35,15 @@ data MIMEType = MIMEType { , mtParams ∷ !(Map CIAscii Text) } deriving (Eq, Show) +-- |Construct a 'MIMEType' without any parameters. +mkMIMEType ∷ CIAscii → CIAscii → MIMEType +{-# INLINE mkMIMEType #-} +mkMIMEType maj min + = MIMEType maj min (∅) + -- |Convert a 'MIMEType' to 'AsciiBuilder'. printMIMEType ∷ MIMEType → AsciiBuilder +{-# INLINEABLE printMIMEType #-} printMIMEType (MIMEType maj min params) = A.toAsciiBuilder (A.fromCIAscii maj) ⊕ A.toAsciiBuilder "/" ⊕ @@ -44,17 +53,20 @@ printMIMEType (MIMEType maj min params) -- |Parse 'MIMEType' from an 'Ascii'. This function throws an -- exception for parse error. parseMIMEType ∷ Ascii → MIMEType +{-# INLINEABLE parseMIMEType #-} parseMIMEType str - = let p = do t ← mimeTypeP - endOfInput - return t - bs = A.toByteString str - in - case parseOnly p bs of - Right t → t - Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err) + = case parseOnly p $ A.toByteString str of + Right t → t + Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err) + where + p ∷ Parser MIMEType + {-# INLINE p #-} + p = do t ← mimeTypeP + endOfInput + return t mimeTypeP ∷ Parser MIMEType +{-# INLINEABLE mimeTypeP #-} mimeTypeP = do maj ← A.toCIAscii <$> token _ ← char '/' min ← A.toCIAscii <$> token @@ -62,4 +74,5 @@ mimeTypeP = do maj ← A.toCIAscii <$> token return $ MIMEType maj min params mimeTypeListP ∷ Parser [MIMEType] +{-# INLINE mimeTypeListP #-} mimeTypeListP = listOf mimeTypeP diff --git a/examples/Multipart.hs b/examples/Multipart.hs index 69c4125..9c42e72 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -1,8 +1,15 @@ -import qualified Data.ByteString.Lazy.Char8 as L8 +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +import qualified Data.ByteString.Lazy.Char8 as Lazy +import Control.Applicative +import Control.Monad.Unicode import Data.Maybe +import Data.Monoid.Unicode import Network.HTTP.Lucu -main :: IO () +main ∷ IO () main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ([], resMain) ] in @@ -10,30 +17,25 @@ main = let config = defaultConfig { cnfServerPort = "9999" } runHttpd config resources [] -resMain :: ResourceDef +resMain ∷ ResourceDef resMain - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do setContentType $ read "text/html" - output ("Multipart Form Test" ++ - "
" ++ - " Upload some file:" ++ - " " ++ - " " ++ - " " ++ - "
") - , resHead = Nothing + = emptyResource { + resGet + = Just $ do setContentType $ mkMIMEType "text" "html" + output ("Multipart Form Test\n" ⊕ + "
\n" ⊕ + " Upload some file:\n" ⊕ + " \n" ⊕ + " \n" ⊕ + " \n" ⊕ + "
\n") , resPost - = Just $ do form <- inputForm defaultLimit - let text = fromMaybe L8.empty $ fmap fdContent $ lookup "text" form - file = fromMaybe L8.empty $ fmap fdContent $ lookup "file" form - fileName = fdFileName =<< lookup "file" form - setContentType $ read "text/plain" - outputChunk ("You entered \"" ++ L8.unpack text ++ "\".\n") - outputChunk ("You uploaded a " ++ show (L8.length file) ++ " bytes long file.\n") - output ("The file name is " ++ show fileName ++ ".\n") - , resPut = Nothing - , resDelete = Nothing - } \ No newline at end of file + = Just $ do form ← inputForm defaultLimit + let text = fromMaybe (∅) $ fdContent <$> lookup "text" form + file = fromMaybe (∅) $ fdContent <$> lookup "file" form + fileName = fdFileName =≪ lookup "file" form + setContentType $ mkMIMEType "text" "plain" + outputChunk ("You entered \"" ⊕ text ⊕ "\".\n") + outputChunk ("You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n") + output ("The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n") + } diff --git a/examples/SSL.hs b/examples/SSL.hs index 436749f..48b2381 100644 --- a/examples/SSL.hs +++ b/examples/SSL.hs @@ -1,20 +1,26 @@ -{-# LANGUAGE PackageImports #-} -import Control.Monad -import "mtl" Control.Monad.Trans -import Data.Time.Clock -import Network.HTTP.Lucu -import OpenSSL -import OpenSSL.EVP.PKey -import OpenSSL.RSA +{-# LANGUAGE + OverloadedStrings + , PackageImports + , UnicodeSyntax + #-} +import Control.Applicative +import "mtl" Control.Monad.Trans +import Control.Monad.Unicode +import qualified Data.ByteString.Lazy.Char8 as Lazy +import Data.Time.Clock +import Network.HTTP.Lucu +import OpenSSL +import OpenSSL.EVP.PKey +import OpenSSL.RSA import qualified OpenSSL.Session as SSL -import OpenSSL.X509 +import OpenSSL.X509 -main :: IO () +main ∷ IO () main = withOpenSSL $ - do ctx <- SSL.context + do ctx ← SSL.context - key <- generateRSAKey 1024 3 Nothing - cert <- genCert key + key ← generateRSAKey 1024 3 Nothing + cert ← genCert key SSL.contextSetPrivateKey ctx key SSL.contextSetCertificate ctx cert SSL.contextSetDefaultCiphers ctx @@ -26,42 +32,32 @@ main = withOpenSSL $ , sslContext = ctx } } - resources = mkResTree [ ( [] - , helloWorld ) - ] + resources = mkResTree [ ([], helloWorld) ] putStrLn "Access https://localhost:9001/ with your browser." runHttpd config resources [] - -helloWorld :: ResourceDef +helloWorld ∷ ResourceDef helloWorld - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do setContentType $ read "text/plain" + = emptyResource { + resGet + = Just $ do setContentType $ parseMIMEType "text/plain" outputChunk "getRemoteCertificate = " - cert <- do c <- getRemoteCertificate - case c of - Just c -> liftIO $ printX509 c - Nothing -> return "Nothing" + cert ← do cert ← getRemoteCertificate + case cert of + Just c → liftIO $ Lazy.pack <$> printX509 c + Nothing → return "Nothing" outputChunk cert - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing } - -genCert :: KeyPair k => k -> IO X509 +genCert ∷ KeyPair k ⇒ k → IO X509 genCert pkey - = do cert <- newX509 + = do cert ← newX509 setVersion cert 2 setSerialNumber cert 1 setIssuerName cert [("CN", "localhost")] setSubjectName cert [("CN", "localhost")] - setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime - setNotAfter cert =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime + setNotBefore cert =≪ addUTCTime (-1) <$> getCurrentTime + setNotAfter cert =≪ addUTCTime (365 * 24 * 60 * 60) <$> getCurrentTime setPublicKey cert pkey signX509 cert pkey Nothing return cert \ No newline at end of file -- 2.40.0