From 70bf5bd248aa426ca4e410b3fb9a0529354aedaf Mon Sep 17 00:00:00 2001 From: pho Date: Sat, 30 Jul 2011 06:06:33 +0900 Subject: [PATCH] Use base64-bytestring instead of dataenc Ignore-this: b9744a1d6732b99150cc61c89c29ea83 darcs-hash:20110729210633-62b54-0d7612049231d2d18766a131413ed1de424aacb5.gz --- ImplantFile.hs | 68 ++++++++++++++--------------- Lucu.cabal | 47 ++++++++------------ Network/HTTP/Lucu/Abortion.hs | 6 ++- Network/HTTP/Lucu/Authorization.hs | 56 +++++++++++++----------- Network/HTTP/Lucu/DefaultPage.hs | 5 +++ Network/HTTP/Lucu/HttpVersion.hs | 4 ++ Network/HTTP/Lucu/Interaction.hs | 4 ++ Network/HTTP/Lucu/MIMEType.hs | 4 ++ Network/HTTP/Lucu/MIMEType/Guess.hs | 4 ++ Network/HTTP/Lucu/MultipartForm.hs | 4 ++ Network/HTTP/Lucu/Parser.hs | 6 +++ Network/HTTP/Lucu/Parser/Http.hs | 4 ++ Network/HTTP/Lucu/Postprocess.hs | 4 ++ Network/HTTP/Lucu/RequestReader.hs | 6 ++- Network/HTTP/Lucu/Resource.hs | 4 ++ Network/HTTP/Lucu/Response.hs | 7 ++- Network/HTTP/Lucu/ResponseWriter.hs | 4 ++ Network/HTTP/Lucu/SocketLike.hs | 6 +++ Network/HTTP/Lucu/StaticFile.hs | 4 ++ Network/HTTP/Lucu/Utils.hs | 4 ++ examples/Makefile | 2 +- 21 files changed, 159 insertions(+), 94 deletions(-) diff --git a/ImplantFile.hs b/ImplantFile.hs index 1d7d43d..fd57fad 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,9 +1,11 @@ -import Codec.Binary.Base64 import Codec.Compression.GZip import Control.Monad import Data.Bits +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Lazy as L hiding (ByteString) +import qualified Data.ByteString.Lazy as LS hiding (ByteString) import Data.Char import Data.Int import Data.Maybe @@ -108,22 +110,22 @@ generateHaskellSource opts srcFile let compParams = defaultCompressParams { compressLevel = bestCompression } gzippedData = compressWith compParams input - originalLen = L.length input - gzippedLen = L.length gzippedData + originalLen = LS.length input + gzippedLen = LS.length gzippedData useGZip = originalLen > gzippedLen - rawB64 = encode $ L.unpack input - gzippedB64 = encode $ L.unpack gzippedData + rawB64 = B64.encode $ BS.concat $ LS.toChunks input + gzippedB64 = B64.encode $ BS.concat $ LS.toChunks gzippedData header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod let hsModule = HsModule undefined (Module modName) (Just exports) imports decls exports = [HsEVar (UnQual (HsIdent symName))] - imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64") - False Nothing Nothing + imports = [ HsImportDecl undefined (Module "Data.ByteString.Base64") + True (Just (Module "B64")) Nothing + , HsImportDecl undefined (Module "Data.ByteString.Char8") + True (Just (Module "C8")) Nothing , HsImportDecl undefined (Module "Data.ByteString.Lazy") - True (Just (Module "L")) Nothing - , HsImportDecl undefined (Module "Data.Maybe") - False Nothing Nothing + True (Just (Module "LS")) Nothing , HsImportDecl undefined (Module "Data.Time") False Nothing Nothing , HsImportDecl undefined (Module "Network.HTTP.Lucu") @@ -295,37 +297,35 @@ generateHaskellSource opts srcFile declGZippedData = [ HsTypeSig undefined [HsIdent "gzippedData"] (HsQualType [] - (HsTyCon (Qual (Module "L") (HsIdent "ByteString")))) + (HsTyCon (Qual (Module "LS") (HsIdent "ByteString")))) , HsFunBind [HsMatch undefined (HsIdent "gzippedData") [] (HsUnGuardedRhs defGZippedData) []] ] defGZippedData :: HsExp defGZippedData - = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "fromJust"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "decode"))) - (HsLit (HsString gzippedB64)))))) + = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks"))) + (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient"))) + (HsParen + (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack"))) + (HsLit (HsString $ C8.unpack gzippedB64))))]) declRawData :: [HsDecl] declRawData = [ HsTypeSig undefined [HsIdent "rawData"] (HsQualType [] - (HsTyCon (Qual (Module "L") (HsIdent "ByteString")))) + (HsTyCon (Qual (Module "LS") (HsIdent "ByteString")))) , HsFunBind [HsMatch undefined (HsIdent "rawData") [] (HsUnGuardedRhs defRawData) []] ] defRawData :: HsExp defRawData - = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "fromJust"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "decode"))) - (HsLit (HsString rawB64)))))) + = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks"))) + (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient"))) + (HsParen + (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack"))) + (HsLit (HsString $ C8.unpack rawB64))))]) hPutStrLn output header hPutStrLn output (prettyPrint hsModule) @@ -435,8 +435,8 @@ getETag opts input openInput :: FilePath -> IO Lazy.ByteString -openInput "-" = L.getContents -openInput fpath = L.readFile fpath +openInput "-" = LS.getContents +openInput fpath = LS.readFile fpath openOutput :: [CmdOpt] -> IO Handle @@ -466,9 +466,9 @@ openOutput opts Last Modified: 2007-11-05 13:53:42.231882 JST -} module Foo.Bar.Baz (baz) where - import Codec.Binary.Base64 - import qualified Data.ByteString.Lazy as L - import Data.Maybe + import qualified Data.ByteString.Base64 as B64 + import qualified Data.ByteString.Char8 as C8 + import qualified Data.ByteString.Lazy as LS import Data.Time import Network.HTTP.Lucu @@ -495,8 +495,8 @@ openOutput opts contentType :: MIMEType contentType = read "image/png" - rawData :: L.ByteString - rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")) + rawData :: LS.ByteString + rawData = LS.fromChunks [B64.decodeLenient (C8.pack "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")] ------------------------------------------------------------------------------ 壓縮される場合は次のやうに變はる: @@ -527,7 +527,7 @@ openOutput opts } -- rawData の代はりに gzippedData - gzippedData :: L.ByteString - gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")) + gzippedData :: LS.ByteString + gzippedData = LS.fromChunks [B64.decodeLenient (C8.pack "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")] ------------------------------------------------------------------------------ -} diff --git a/Lucu.cabal b/Lucu.cabal index 6a37744..4452ee1 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -44,22 +44,23 @@ Flag build-lucu-implant-file Library Build-Depends: - HsOpenSSL == 0.10.*, - base == 4.3.*, - bytestring == 0.9.*, - containers == 0.4.*, - dataenc == 0.14.*, - filepath == 1.2.*, - directory == 1.1.*, - haskell-src == 1.0.*, - hxt == 9.1.*, - mtl == 2.0.*, - network == 2.3.*, - stm == 2.2.*, - time == 1.2.*, - time-http == 0.1.*, - unix == 2.4.*, - zlib == 0.5.* + HsOpenSSL == 0.10.*, + base == 4.3.*, + base-unicode-symbols == 0.2.*, + base64-bytestring == 0.1.*, + bytestring == 0.9.*, + containers == 0.4.*, + filepath == 1.2.*, + directory == 1.1.*, + haskell-src == 1.0.*, + hxt == 9.1.*, + mtl == 2.0.*, + network == 2.3.*, + stm == 2.2.*, + time == 1.2.*, + time-http == 0.1.*, + unix == 2.4.*, + zlib == 0.5.* Exposed-Modules: Network.HTTP.Lucu @@ -96,15 +97,6 @@ Library Network.HTTP.Lucu.ResponseWriter Network.HTTP.Lucu.SocketLike - Extensions: - BangPatterns - DeriveDataTypeable - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - TypeFamilies - UnboxedTuples - ghc-options: -Wall -funbox-strict-fields @@ -117,11 +109,6 @@ Executable lucu-implant-file Main-Is: ImplantFile.hs - Extensions: - BangPatterns - ScopedTypeVariables - UnboxedTuples - ghc-options: -Wall -funbox-strict-fields diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index db0c552..26ea8b0 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + DeriveDataTypeable + , UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource' @@ -18,7 +22,7 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad.Trans import qualified Data.ByteString.Char8 as C8 -import Data.Dynamic +import Data.Typeable import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs index 8e1be58..6b0e1c2 100644 --- a/Network/HTTP/Lucu/Authorization.hs +++ b/Network/HTTP/Lucu/Authorization.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE + UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |Manipulation of WWW authorization. @@ -11,12 +14,12 @@ module Network.HTTP.Lucu.Authorization , authCredentialP -- private ) where - -import qualified Codec.Binary.Base64 as B64 -import Data.Maybe -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import Prelude.Unicode -- |Authorization challenge to be sent to client with -- \"WWW-Authenticate\" header. See @@ -26,7 +29,7 @@ data AuthChallenge deriving (Eq) -- |'Realm' is just a string which must not contain any non-ASCII letters. -type Realm = String +type Realm = String -- |Authorization credential to be sent by client with -- \"Authorization\" header. See @@ -43,25 +46,26 @@ type UserID = String -- letters. type Password = String - instance Show AuthChallenge where show (BasicAuthChallenge realm) - = "Basic realm=" ++ quoteStr realm + = "Basic realm=" ⧺ quoteStr realm - -authCredentialP :: Parser AuthCredential -authCredentialP = allowEOF $! - do _ <- string "Basic" - _ <- many1 lws - b64 <- many1 - $ satisfy (\ c -> (c >= 'a' && c <= 'z') || - (c >= 'A' && c <= 'Z') || - (c >= '0' && c <= '9') || - c == '+' || - c == '/' || - c == '=') - let decoded = map (toEnum . fromEnum) (fromJust $ B64.decode b64) - case break (== ':') decoded of - (uid, ':' : password) - -> return (BasicAuthCredential uid password) - _ -> failP +authCredentialP ∷ Parser AuthCredential +authCredentialP + = allowEOF $! + do _ ← string "Basic" + _ ← many1 lws + b64 ← many1 + $ satisfy (\c → (c ≥ 'a' ∧ c ≤ 'z') ∨ + (c ≥ 'A' ∧ c ≤ 'Z') ∨ + (c ≥ '0' ∧ c ≤ '9') ∨ + c ≡ '+' ∨ + c ≡ '/' ∨ + c ≡ '=') + case break (≡ ':') (decode b64) of + (uid, ':' : password) + → return (BasicAuthCredential uid password) + _ → failP + where + decode ∷ String → String + decode = C8.unpack ∘ B64.decodeLenient ∘ C8.pack diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 5fd1705..12aba15 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + BangPatterns + , UnboxedTuples + , UnicodeSyntax + #-} module Network.HTTP.Lucu.DefaultPage ( getDefaultPage , writeDefaultPage diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index ca25640..d48f6ec 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |Manipulation of HTTP version string. diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 4c93b41..638d1b0 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index b7ceb40..a3f3fc5 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + UnboxedTuples + , UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |Manipulation of MIME Types. diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 145adf8..39de37e 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + UnboxedTuples + , UnicodeSyntax + #-} -- |MIME Type guessing by a file extension. This is a poor man's way -- of guessing MIME Types. It is simple and fast. -- diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index a2ee492..c463130 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + UnboxedTuples + , UnicodeSyntax + #-} module Network.HTTP.Lucu.MultipartForm ( FormData(..) , multipartFormP diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 34953f5..7809f53 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE + BangPatterns + , ScopedTypeVariables + , UnboxedTuples + , UnicodeSyntax + #-} -- |Yet another parser combinator. This is mostly a subset of -- "Text.ParserCombinators.Parsec" but there are some differences: -- diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index 78e4818..fe54bde 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} -- |This is an auxiliary parser utilities for parsing things related -- on HTTP protocol. -- diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 0bd33ed..806ed1c 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Postprocess ( postprocess , completeUnconditionalHeaders diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index cfc991a..d3b8daa 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + BangPatterns + , UnboxedTuples + , UnicodeSyntax + #-} module Network.HTTP.Lucu.RequestReader ( requestReader ) @@ -27,7 +32,6 @@ import Network.HTTP.Lucu.Resource.Tree import Prelude hiding (catch) import System.IO (stderr) - requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO () requestReader !cnf !tree !fbs !h !port !addr !tQueue = do input <- hGetLBS h diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 15b211f..fa08fa5 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + UnboxedTuples + , UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |This is the Resource Monad; monadic actions to define the behavior diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 4954bc2..adf8505 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + DeriveDataTypeable + , UnboxedTuples + , UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |Definition of things related on HTTP response. @@ -17,7 +22,7 @@ module Network.HTTP.Lucu.Response import qualified Data.ByteString as Strict (ByteString) import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Dynamic +import Data.Typeable import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Headers diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 7892e2a..9751a76 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.ResponseWriter ( responseWriter ) diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs index b99811f..915f323 100644 --- a/Network/HTTP/Lucu/SocketLike.hs +++ b/Network/HTTP/Lucu/SocketLike.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE + FlexibleContexts + , FlexibleInstances + , TypeFamilies + , UnicodeSyntax + #-} module Network.HTTP.Lucu.SocketLike ( SocketLike(..) ) diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 7ceb787..9175ce9 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} -- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index f1c178d..c85c9a7 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} -- |Utility functions used internally in the Lucu httpd. These -- functions may be useful too for something else. module Network.HTTP.Lucu.Utils diff --git a/examples/Makefile b/examples/Makefile index 3e2c6f0..abd928e 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -16,7 +16,7 @@ run: build ./HelloWorld clean: - rm -f $(TARGETS) *.hi *.o + rm -f $(TARGETS) *.hi *.o MiseRafturai.hs SmallFile.hs MiseRafturai.hs: mise-rafturai.html lucu-implant-file -m MiseRafturai -o $@ $< -- 2.40.0