ImplantFile.hs now compiles.

[Lucu.git] / ImplantFile.hs

diff --git a/ImplantFile.hs b/ImplantFile.hs
index b95c45508cd23d11a134451081edd61c4de45a42..0e91f1c6bdbb7bd2b5667d68790325ad5ad88a95 100644 (file)
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -1,16 +1,17 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    UnicodeSyntax
+    OverloadedStrings
+  , UnicodeSyntax

   #-}
 module Main where
 import Codec.Compression.GZip
 import Control.Applicative
 import Control.Monad
 import qualified Data.Ascii as A
   #-}
 module Main where
 import Codec.Compression.GZip
 import Control.Applicative
 import Control.Monad
 import qualified Data.Ascii as A

-import Data.Bits

 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Char
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Char

+import Data.Digest.Pure.SHA

 import Data.Int
 import Data.Maybe
 import Data.Time
 import Data.Int
 import Data.Maybe
 import Data.Time


@@ -99,7 +100,7 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
                     exitWith $ ExitFailure 1
 
           when (length sources ≥ 2)
                     exitWith $ ExitFailure 1
 
           when (length sources ≥ 2)

-               $ error "too many input files."
+               $ fail "too many input files."

 
           generateHaskellSource opts (head sources)
 
 
           generateHaskellSource opts (head sources)
 


@@ -123,9 +124,9 @@ generateHaskellSource opts srcFile
 
          header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 
 
          header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 

-         let hsModule = mkModule (ModuleName modName) (name symName) imports decls
+         let hsModule = mkModule modName symName imports decls

              imports  = mkImports useGZip
              imports  = mkImports useGZip

-             decls    = concat [ declResourceDef
+             decls    = concat [ resourceDecl symName useGZip

                                , entityTagDecl eTag
                                , lastModifiedDecl lastMod
                                , contentTypeDecl mimeType
                                , entityTagDecl eTag
                                , lastModifiedDecl lastMod
                                , contentTypeDecl mimeType


@@ -134,103 +135,53 @@ generateHaskellSource opts srcFile
                                  else
                                      dataDecl (name "rawData") rawB64
                                ]
                                  else
                                      dataDecl (name "rawData") rawB64
                                ]

-             declResourceDef
-                 = [ HsTypeSig (⊥) [HsIdent symName]
-                               (HsQualType []
-                                (HsTyCon (UnQual (HsIdent "ResourceDef"))))
-                   , HsFunBind [HsMatch (⊥) (HsIdent symName)
-                                [] (HsUnGuardedRhs defResourceDef) []]
-                   ]
-
-             defResourceDef ∷ HsExp
-             defResourceDef 
-                 = let defResGet = if useGZip
-                                   then defResGetGZipped
-                                   else resGetRaw
-                   in 
-                     (HsRecConstr (UnQual (HsIdent "ResourceDef"))
-                      [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
-                                      (HsCon (UnQual (HsIdent "False")))
-                      , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
-                                      (HsCon (UnQual (HsIdent "False")))
-                      , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
-                      , HsFieldUpdate (UnQual (HsIdent "resHead"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      , HsFieldUpdate (UnQual (HsIdent "resPost"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      , HsFieldUpdate (UnQual (HsIdent "resPut"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      , HsFieldUpdate (UnQual (HsIdent "resDelete"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      ]
-                     )
-
-             defResGetGZipped ∷ HsExp
-             defResGetGZipped
-                 = let doExp = HsDo [ foundEntityStmt
-                                    , setContentTypeStmt
-                                    , bindMustGunzip
-                                    , doConditionalOutput
-                                    ]
-                       bindMustGunzip
-                           = HsGenerator (⊥)
-                             (HsPVar (HsIdent "mustGunzip"))
-                             (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
-                                     (HsVar (UnQual (HsIdent "not"))))
-                              (HsParen
-                               (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
-                                      (HsLit (HsString "gzip")))))
-                       doConditionalOutput
-                           = HsQualifier
-                             (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
-                                   expOutputGunzipped
-                                   expOutputGZipped)
-                       expOutputGunzipped
-                           = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
-                              (HsParen
-                               (HsApp (HsVar (UnQual (HsIdent "decompress")))
-                                      (HsVar (UnQual (HsIdent "gzippedData"))))))
-                       expOutputGZipped
-                           = HsDo [ setContentEncodingGZipStmt
-                                  , outputStmt (var $ name "gzippedData")
-                                  ]
-                   in 
-                     HsApp (HsCon (UnQual (HsIdent "Just")))
-                           (HsParen doExp)

 
          hPutStrLn output header
          hPutStrLn output (prettyPrint hsModule)
          hClose output
 
 
          hPutStrLn output header
          hPutStrLn output (prettyPrint hsModule)
          hClose output
 

-mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl]
+mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module

 mkModule modName symName imports decls
 mkModule modName symName imports decls

-    = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings)
-                                           ]
-                      ]
-          exports   = [ EVar (UnQual symName)
-                      ]
+    = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
+          exports   = [ EVar (UnQual symName) ]

       in
         Module (⊥) modName modPragma Nothing (Just exports) imports decls
 
 mkImports ∷ Bool → [ImportDecl]
 mkImports useGZip
     = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
       in
         Module (⊥) modName modPragma Nothing (Just exports) imports decls
 
 mkImports ∷ Bool → [ImportDecl]
 mkImports useGZip
     = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")

-                   True False (Just (ModuleName "B64")) Nothing
+                   True False Nothing (Just (ModuleName "B64")) Nothing

       , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
       , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")

-                   True False (Just (ModuleName "Lazy")) Nothing
+                   True False Nothing (Just (ModuleName "Lazy")) Nothing

       , ImportDecl (⊥) (ModuleName "Data.Time")
       , ImportDecl (⊥) (ModuleName "Data.Time")

-                   False False Nothing Nothing
+                   False False Nothing Nothing Nothing

       , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
       , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")

-                   False False Nothing Nothing
+                   False False Nothing Nothing Nothing

       ]
       ⧺
       if useGZip then
           [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
       ]
       ⧺
       if useGZip then
           [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")

-                       False False Nothing Nothing
+                       False False Nothing Nothing Nothing

           ]
       else
           []
 
           ]
       else
           []
 

+resourceDecl ∷ Name → Bool → [Decl]
+resourceDecl symName useGZip
+    = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
+      , nameBind (⊥) symName valExp
+      ]
+    where
+      valExp ∷ Exp
+      valExp = RecUpdate (var $ name "emptyResource")
+               [ FieldUpdate (UnQual (name "resGet" )) resGet
+               , FieldUpdate (UnQual (name "resHead")) resHead
+               ]
+
+      resGet ∷ Exp
+      resGet | useGZip   = resGetGZipped
+             | otherwise = resGetRaw
+

 resHead ∷ Exp
 resHead
     = infixApp (var $ name "Just")
 resHead ∷ Exp
 resHead
     = infixApp (var $ name "Just")


@@ -239,6 +190,38 @@ resHead
                     , setContentTypeStmt
                     ])
 
                     , setContentTypeStmt
                     ])
 

+resGetGZipped ∷ Exp
+resGetGZipped
+    = infixApp (var $ name "Just")
+               (op  $ name "$"   )
+               (doE [ foundEntityStmt
+                    , setContentTypeStmt
+                    , bindGZipStmt
+                    , conditionalOutputStmt
+                    ])
+    where
+      condVarName ∷ Name
+      condVarName = name "gzipAllowed"
+
+      dataVarName ∷ Name
+      dataVarName = name "gzippedData"
+
+      bindGZipStmt ∷ Stmt
+      bindGZipStmt
+          = genStmt (⊥)
+            (pvar condVarName)
+            (metaFunction "isEncodingAcceptable" [strE "gzip"])
+
+      conditionalOutputStmt ∷ Stmt
+      conditionalOutputStmt
+          = qualStmt $
+            If (var condVarName)
+               (doE [ setContentEncodingGZipStmt
+                    , outputStmt (var dataVarName)
+                    ])
+               (metaFunction "output"
+                [paren (metaFunction "decompress" [var dataVarName])])
+

 resGetRaw ∷ Exp
 resGetRaw
     = infixApp (var $ name "Just")
 resGetRaw ∷ Exp
 resGetRaw
     = infixApp (var $ name "Just")


@@ -285,9 +268,6 @@ entityTagDecl eTag
       valExp ∷ Exp
       valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
 
       valExp ∷ Exp
       valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
 

-      eTagToString ∷ ETag → String
-      eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
-

 lastModifiedDecl ∷ UTCTime → [Decl]
 lastModifiedDecl lastMod
     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
 lastModifiedDecl ∷ UTCTime → [Decl]
 lastModifiedDecl lastMod
     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))


@@ -310,7 +290,7 @@ contentTypeDecl mime
       varName = name "contentType"
 
       valExp ∷ Exp
       varName = name "contentType"
 
       valExp ∷ Exp

-      valExp = metaFunction "parseMIMEType" [mimeToString mime]
+      valExp = metaFunction "parseMIMEType" [strE $ mimeToString mime]

 
       mimeToString ∷ MIMEType → String
       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 
       mimeToString ∷ MIMEType → String
       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType


@@ -332,64 +312,77 @@ dataDecl varName chunks
             `app`
             strE (Strict.unpack chunk)
 
             `app`
             strE (Strict.unpack chunk)
 

-mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → String → UTCTime → IO String
+mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String

 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
     = do localLastMod ← utcToLocalZonedTime lastMod
 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
     = do localLastMod ← utcToLocalZonedTime lastMod

-         return ("{- DO NOT EDIT THIS FILE.\n" ++
-                 "   This file is automatically generated by the lucu-implant-file program.\n" ++
-                 "\n" ++
-                 "              Source: " ++ (if srcFile ≡ "-"
-                                              then "(stdin)"
-                                              else srcFile) ++ "\n" ++
-                 "     Original Length: " ++ show originalLen ++ " bytes\n" ++
-                 (if useGZip
-                  then "   Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
-                       "         Compression: gzip\n"
-                  else "         Compression: disabled\n") ++
-                 "           MIME Type: " ++ show mimeType ++ "\n" ++
-                 "                ETag: " ++ eTag ++ "\n" ++
-                 "       Last Modified: " ++ show localLastMod ++ "\n" ++
-                 " -}")
-
-
-getModuleName ∷ [CmdOpt] → IO String
+         return $ concat
+                    [ "{- DO NOT EDIT THIS FILE.\n"
+                    , "   This file is automatically generated by the lucu-implant-file program.\n"
+                    , "\n"
+                    , "              Source: ", if srcFile ≡ "-" then
+                                                    "(stdin)"
+                                                else
+                                                    srcFile
+                    , "\n"
+                    , "     Original Length: ", show originalLen, " bytes\n"
+                    , if useGZip then
+                          "   Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺
+                          "         Compression: gzip\n"
+                      else
+                          "         Compression: disabled\n"
+                    , "           MIME Type: ", show mimeType, "\n"
+                    , "                ETag: ", eTagToString eTag, "\n"
+                    , "       Last Modified: ", show localLastMod, "\n"
+                    , " -}"
+                    ]
+
+eTagToString ∷ ETag → String
+eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
+
+getModuleName ∷ [CmdOpt] → IO ModuleName

 getModuleName opts
 getModuleName opts

-    = let modNameOpts = filter (\ x → case x of
-                                         OptModName _ → True
-                                         _            → False) opts
-      in
-        case modNameOpts of
-          []                      → error "a module name must be given."
-          (OptModName modName):[] → return modName
-          _                       → error "too many --module options."
-
-
-getSymbolName ∷ [CmdOpt] → String → IO String
-getSymbolName opts modName
-    = let symNameOpts    = filter (\ x → case x of
-                                            OptSymName _ → True
-                                            _            → False) opts
-          -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
-          -- 小文字にしたものを使ふ。
-          defaultSymName  = mkDefault modName
-          mkDefault       = headToLower ∘ getLastComp
-          headToLower str = case str of
-                              []     → error "module name must not be empty"
-                              (x:xs) → toLower x : xs
-          getLastComp     = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
-      in
-        case symNameOpts of
-          []                      → return defaultSymName
-          (OptSymName symName):[] → return symName
-          _                       → error "too many --symbol options."
+    = case modNameOpts of
+        []                      → fail "a module name must be given."
+        (OptModName modName):[] → return $ ModuleName modName
+        _                       → fail "too many --module options."
+    where
+      modNameOpts ∷ [CmdOpt]
+      modNameOpts = filter (\ x → case x of
+                                     OptModName _ → True
+                                     _            → False) opts
+
+getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
+getSymbolName opts (ModuleName modName)
+    = case symNameOpts of
+        []                      → return defaultSymName
+        (OptSymName symName):[] → return $ name symName
+        _                       → fail "too many --symbol options."
+    where
+      symNameOpts ∷ [CmdOpt]
+      symNameOpts = filter (\ x → case x of
+                                     OptSymName _ → True
+                                     _            → False) opts
+
+      defaultSymName ∷ Name
+      defaultSymName
+          = name $ headToLower $ getLastComp modName

 
 

+      headToLower ∷ String → String
+      headToLower []     = error "module name must not be empty"
+      headToLower (x:xs) = toLower x : xs
+
+      getLastComp ∷ String → String
+      getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse

 
 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
 getMIMEType opts srcFile
     = case mimeTypeOpts of
 
 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
 getMIMEType opts srcFile
     = case mimeTypeOpts of

-        []                  → return defaultType
-        (OptMIMEType ty):[] → return $ read ty
-        _                   → error "too many --mime-type options."
+        []  → return defaultType
+        (OptMIMEType ty):[]
+            → case A.fromChars ty of
+                 Just a  → return $ parseMIMEType a
+                 Nothing → fail "MIME type must not contain any non-ASCII letters."
+        _   → fail "too many --mime-type options."

     where
       mimeTypeOpts ∷ [CmdOpt]
       mimeTypeOpts
     where
       mimeTypeOpts ∷ [CmdOpt]
       mimeTypeOpts


@@ -404,59 +397,49 @@ getMIMEType opts srcFile
       defaultType = fromMaybe octetStream
                     $ guessTypeByFileName defaultExtensionMap srcFile
 
       defaultType = fromMaybe octetStream
                     $ guessTypeByFileName defaultExtensionMap srcFile
 

-

 getLastModified ∷ FilePath → IO UTCTime
 getLastModified "-"   = getCurrentTime
 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
                         <$>
                         getFileStatus fpath
 
 getLastModified ∷ FilePath → IO UTCTime
 getLastModified "-"   = getCurrentTime
 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
                         <$>
                         getFileStatus fpath
 

-
-getETag ∷ [CmdOpt] → Lazy.ByteString → IO String
+getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag

 getETag opts input
 getETag opts input

-    = let eTagOpts = filter (\ x → case x of
-                                      OptETag _ → True
-                                      _         → False) opts
-      in
-        case eTagOpts of
-          []               → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1")
-          (OptETag str):[] → return str
-          _                → error "too many --etag options."
+    = case eTagOpts of
+        []               → return $ mkETagFromInput
+        (OptETag str):[] → return $ strToETag str
+        _                → fail "too many --etag options."

     where
     where

-      mkETagFromInput ∷ Digest → String
-      mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)
-
-      toHex ∷ String → String
-      toHex = foldr ((++) ∘ hexByte ∘ fromEnum) ""
-
-      hexByte ∷ Int → String
-      hexByte n
-          = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
-            , hex4bit ( n             .&. 0x0F)
-            ]
+      eTagOpts ∷ [CmdOpt]
+      eTagOpts = filter (\ x → case x of
+                                  OptETag _ → True
+                                  _         → False) opts

 
 

-      hex4bit ∷ Int → Char
-      hex4bit n
-          | n < 10    = chr $ ord '0' + n
-          | n < 16    = chr $ ord 'a' + n - 10
-          | otherwise = (⊥)
+      mkETagFromInput ∷ ETag
+      mkETagFromInput
+          = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)

 
 

+      strToETag ∷ String → ETag
+      strToETag str
+          = case A.fromChars str of
+              Just a  → strongETag a
+              Nothing → error "ETag must not contain any non-ASCII letters."

 
 openInput ∷ FilePath → IO Lazy.ByteString
 openInput "-"   = Lazy.getContents
 openInput fpath = Lazy.readFile fpath
 
 
 openInput ∷ FilePath → IO Lazy.ByteString
 openInput "-"   = Lazy.getContents
 openInput fpath = Lazy.readFile fpath
 

-

 openOutput ∷ [CmdOpt] → IO Handle
 openOutput opts
 openOutput ∷ [CmdOpt] → IO Handle
 openOutput opts

-    = let outputOpts = filter (\ x → case x of
-                                        OptOutput _ → True
-                                        _           → False) opts
-      in
-        case outputOpts of
-          []                   → return stdout
-          (OptOutput fpath):[] → openFile fpath WriteMode
-          _                    → error "two many --output options."
+    = case outputOpts of
+        []                   → return stdout
+        (OptOutput fpath):[] → openFile fpath WriteMode
+        _                    → fail "two many --output options."
+    where
+      outputOpts ∷ [CmdOpt]
+      outputOpts = filter (\ x → case x of
+                                    OptOutput _ → True
+                                    _           → False) opts

 
 {-
   作られるファイルの例 (壓縮されない場合):
 
 {-
   作られるファイルの例 (壓縮されない場合):


@@ -469,7 +452,7 @@ openOutput opts
      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
            Compression: disabled
              MIME Type: image/png
      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
            Compression: disabled
              MIME Type: image/png

-                  ETag: d41d8cd98f00b204e9800998ecf8427e
+                  ETag: "d41d8cd98f00b204e9800998ecf8427e"

          Last Modified: 2007-11-05 13:53:42.231882 JST
    -}
   {-# LANGUAGE OverloadedStrings #-}
          Last Modified: 2007-11-05 13:53:42.231882 JST
    -}
   {-# LANGUAGE OverloadedStrings #-}


@@ -525,8 +508,8 @@ openOutput opts
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
 
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
 

-                        gzip ← isEncodingAcceptable "gzip"
-                        if gzip then
+                        gzipAllowed ← isEncodingAcceptable "gzip"
+                        if gzipAllowed then

                             do setContentEncoding ["gzip"]
                                output gzippedData
                         else
                             do setContentEncoding ["gzip"]
                                output gzippedData
                         else