X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=ImplantFile.hs;h=60f9b54755911f631c693a053129867bb836f687;hp=b95c45508cd23d11a134451081edd61c4de45a42;hb=b22e702f8161447a460847c6e6c97104c150534f;hpb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7

diff --git a/ImplantFile.hs b/ImplantFile.hs
index b95c455..60f9b54 100644
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -1,33 +1,22 @@
 {-# LANGUAGE
     UnicodeSyntax
   #-}
-module Main where
-import Codec.Compression.GZip
+module Main (main) where
 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 Data.Int
 import Data.Maybe
-import Data.Time
-import Data.Time.Clock.POSIX
-import Language.Haskell.Exts.Build
-import Language.Haskell.Exts.Extension
-import Language.Haskell.Exts.Pretty
-import Language.Haskell.Exts.Syntax
+import Language.Haskell.TH.PprLib
+import Language.Haskell.TH.Syntax
 import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.Implant
+import Network.HTTP.Lucu.Implant.PrettyPrint
 import Network.HTTP.Lucu.MIMEType
-import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
-import Network.HTTP.Lucu.MIMEType.Guess
 import Prelude.Unicode
 import System.Console.GetOpt
 import System.Environment
 import System.Exit
-import System.Posix.Files
 import System.IO
 
 data CmdOpt
@@ -40,27 +29,27 @@ data CmdOpt
     deriving (Eq, Show)
 
 options ∷ [OptDescr CmdOpt]
-options = [ Option ['o'] ["output"]
+options = [ Option "o" ["output"]
                        (ReqArg OptOutput "FILE")
                        "Output to the FILE."
 
-          , Option ['m'] ["module"]
+          , Option "m" ["module"]
                        (ReqArg OptModName "MODULE")
                        "Specify the resulting module name. (required)"
 
-          , Option ['s'] ["symbol"]
+          , Option "s" ["symbol"]
                        (ReqArg OptSymName "SYMBOL")
                        "Specify the resulting symbol name."
 
-          , Option ['t'] ["mime-type"]
+          , Option "t" ["mime-type"]
                        (ReqArg OptMIMEType "TYPE")
                        "Specify the MIME Type of the file."
 
-          , Option ['e'] ["etag"]
+          , Option "e" ["etag"]
                        (ReqArg OptETag "TAG")
                        "Specify the ETag of the file."
 
-          , Option ['h'] ["help"]
+          , Option "h" ["help"]
                        (NoArg OptHelp)
                        "Print this message."
           ]
@@ -72,7 +61,7 @@ printUsage = do mapM_ putStrLn msg
     where
       msg = [ ""
             , "Description:"
-            , concat [ "  lucu-implant-file is an utility that generates " 
+            , concat [ "  lucu-implant-file is an utility that generates "
                      , "Haskell code containing an arbitrary file to "
                      , "compile it directly into programs and serve it "
                      , "statically with the Lucu HTTP server."
@@ -99,297 +88,19 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
                     exitWith $ ExitFailure 1
 
           when (length sources ≥ 2)
-               $ error "too many input files."
+               $ fail "too many input files."
 
           generateHaskellSource opts (head sources)
 
-generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
-generateHaskellSource opts srcFile
-    = do modName  ← getModuleName opts
-         symName  ← getSymbolName opts modName
-         mimeType ← getMIMEType opts srcFile
-         lastMod  ← getLastModified srcFile
-         input    ← openInput srcFile
-         output   ← openOutput opts
-         eTag     ← getETag opts input
-
-         let compParams  = defaultCompressParams { compressLevel = bestCompression }
-             gzippedData = compressWith compParams input
-             originalLen = Lazy.length input
-             gzippedLen  = Lazy.length gzippedData
-             useGZip     = originalLen > gzippedLen
-             rawB64      = B64.encode <$> Lazy.toChunks input
-             gzippedB64  = B64.encode <$> Lazy.toChunks gzippedData
-
-         header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
-
-         let hsModule = mkModule (ModuleName modName) (name symName) imports decls
-             imports  = mkImports useGZip
-             decls    = concat [ declResourceDef
-                               , entityTagDecl eTag
-                               , lastModifiedDecl lastMod
-                               , contentTypeDecl mimeType
-                               , if useGZip then
-                                     dataDecl (name "gzippedData") gzippedB64
-                                 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
-
-mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl]
-mkModule modName symName imports decls
-    = 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")
-                   True False (Just (ModuleName "B64")) Nothing
-      , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
-                   True False (Just (ModuleName "Lazy")) Nothing
-      , ImportDecl (⊥) (ModuleName "Data.Time")
-                   False False Nothing Nothing
-      , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
-                   False False Nothing Nothing
-      ]
-      ⧺
-      if useGZip then
-          [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
-                       False False Nothing Nothing
-          ]
-      else
-          []
-
-resHead ∷ Exp
-resHead
-    = infixApp (var $ name "Just")
-               (op  $ name "$"   )
-               (doE [ foundEntityStmt
-                    , setContentTypeStmt
-                    ])
-
-resGetRaw ∷ Exp
-resGetRaw
-    = infixApp (var $ name "Just")
-               (op  $ name "$"   )
-               (doE [ foundEntityStmt
-                    , setContentTypeStmt
-                    , outputStmt (var $ name "rawData")
-                    ])
-
-setContentEncodingGZipStmt ∷ Stmt
-setContentEncodingGZipStmt
-    = qualStmt $
-      metaFunction "setContentEncoding" $
-      [ listE [ strE "gzip" ] ]
-
-foundEntityStmt ∷ Stmt
-foundEntityStmt
-    = qualStmt $
-      metaFunction "foundEntity" $
-      [ var $ name "entityTag"
-      , var $ name "lastModified"
-      ]
-
-setContentTypeStmt ∷ Stmt
-setContentTypeStmt
-    = qualStmt $
-      metaFunction "setContentType" $
-      [var $ name "contentType"]
-
-outputStmt ∷ Exp → Stmt
-outputStmt e
-    = qualStmt $
-      metaFunction "output" [e]
-
-entityTagDecl ∷ ETag → [Decl]
-entityTagDecl eTag
-    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      varName ∷ Name
-      varName = name "entityTag"
-
-      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")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      varName ∷ Name
-      varName = name "lastModified"
-
-      valExp ∷ Exp
-      valExp = metaFunction "read" [strE $ show lastMod]
-
-contentTypeDecl ∷ MIMEType → [Decl]
-contentTypeDecl mime
-    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      varName ∷ Name
-      varName = name "contentType"
-
-      valExp ∷ Exp
-      valExp = metaFunction "parseMIMEType" [mimeToString mime]
-
-      mimeToString ∷ MIMEType → String
-      mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
-
-dataDecl ∷ Name → [Strict.ByteString] → [Decl]
-dataDecl varName chunks
-    = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      valExp ∷ Exp
-      valExp = qvar (ModuleName "Lazy") (name "fromChunks")
-               `app`
-               listE (chunkToExp <$> chunks)
-
-      chunkToExp ∷ Strict.ByteString → Exp
-      chunkToExp chunk
-          = qvar (ModuleName "B64") (name "decodeLenient")
-            `app`
-            strE (Strict.unpack chunk)
-
-mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → String → UTCTime → IO String
-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
-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."
-
-
-getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
-getMIMEType opts srcFile
+getMIMEType ∷ [CmdOpt] → Maybe MIMEType
+getMIMEType opts
     = case mimeTypeOpts of
-        []                  → return defaultType
-        (OptMIMEType ty):[] → return $ read ty
-        _                   → error "too many --mime-type options."
+        []  → Nothing
+        OptMIMEType ty:[]
+            → case A.fromChars ty of
+                 Just a  → Just $ parseMIMEType a
+                 Nothing → error "MIME types must not contain any non-ASCII letters."
+        _   → error "too many --mime-type options."
     where
       mimeTypeOpts ∷ [CmdOpt]
       mimeTypeOpts
@@ -397,153 +108,83 @@ getMIMEType opts srcFile
                              OptMIMEType _ → True
                              _             → False) opts
 
-      octetStream ∷ MIMEType
-      octetStream = parseMIMEType "application/octet-stream"
-
-      defaultType ∷ MIMEType
-      defaultType = fromMaybe octetStream
-                    $ guessTypeByFileName defaultExtensionMap srcFile
-
-
-getLastModified ∷ FilePath → IO UTCTime
-getLastModified "-"   = getCurrentTime
-getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
-                        <$>
-                        getFileStatus fpath
-
-
-getETag ∷ [CmdOpt] → Lazy.ByteString → IO String
-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."
+getETag ∷ [CmdOpt] → Maybe ETag
+getETag opts
+    = case eTagOpts of
+        []             → Nothing
+        OptETag str:[] → Just $ strToETag str
+        _              → error "too many --etag options."
     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)
-            ]
-
-      hex4bit ∷ Int → Char
-      hex4bit n
-          | n < 10    = chr $ ord '0' + n
-          | n < 16    = chr $ ord 'a' + n - 10
-          | otherwise = (⊥)
-
-
-openInput ∷ FilePath → IO Lazy.ByteString
-openInput "-"   = Lazy.getContents
-openInput fpath = Lazy.readFile fpath
+      eTagOpts ∷ [CmdOpt]
+      eTagOpts = filter (\ x → case x of
+                                  OptETag _ → True
+                                  _         → False) opts
 
+      strToETag ∷ String → ETag
+      strToETag str
+          = case A.fromChars str of
+              Just a  → strongETag a
+              Nothing → error "ETag must not contain any non-ASCII letters."
 
 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."
-
-{-
-  作られるファイルの例 (壓縮されない場合):
-  ------------------------------------------------------------------------------
-  {- DO NOT EDIT THIS FILE.
-     This file is automatically generated by the lucu-implant-file program.
-     
-                Source: baz.png
-       Original Length: 302 bytes
-     Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
-           Compression: disabled
-             MIME Type: image/png
-                  ETag: d41d8cd98f00b204e9800998ecf8427e
-         Last Modified: 2007-11-05 13:53:42.231882 JST
-   -}
-  {-# LANGUAGE OverloadedStrings #-}
-  module Foo.Bar.Baz (baz) where
-  import qualified Data.ByteString.Base64 as B64
-  import qualified Data.ByteString.Lazy as Lazy
-  import Data.Time
-  import Network.HTTP.Lucu
-
-  baz ∷ ResourceDef
-  baz = ResourceDef {
-          resUsesNativeThread = False
-        , resIsGreedy         = False
-        , resGet
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
-                        output rawData
-        , resHead
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
-        , resPost   = Nothing
-        , resPut    = Nothing
-        , resDelete = Nothing
-        }
-
-  entityTag ∷ ETag
-  entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
-
-  lastModified ∷ UTCTime
-  lastModified = read "2007-11-05 04:47:56.008366 UTC"
+    = case outputOpts of
+        []                 → return stdout
+        OptOutput fpath:[] → do h ← openFile fpath WriteMode
+                                hSetEncoding h utf8
+                                return h
+        _                  → fail "two many --output options."
+    where
+      outputOpts ∷ [CmdOpt]
+      outputOpts = filter (\ x → case x of
+                                    OptOutput _ → True
+                                    _           → False) opts
 
-  contentType ∷ MIMEType
-  contentType = parseMIMEType "image/png"
+getModuleName ∷ [CmdOpt] → ModName
+getModuleName opts
+    = case modNameOpts of
+        []                 → error "a module name must be given."
+        OptModName name:[] → mkModName name
+        _                  → error "too many --module options."
+    where
+      modNameOpts ∷ [CmdOpt]
+      modNameOpts = filter (\ x → case x of
+                                     OptModName _ → True
+                                     _            → False) opts
+
+getSymbolName ∷ [CmdOpt] → Maybe Name
+getSymbolName opts
+    = case symNameOpts of
+        []                 → Nothing
+        OptSymName name:[] → Just $ mkName name
+        _                  → fail "too many --symbol options."
+    where
+      symNameOpts ∷ [CmdOpt]
+      symNameOpts = filter (\ x → case x of
+                                     OptSymName _ → True
+                                     _            → False) opts
 
-  rawData ∷ Lazy.ByteString
-  rawData = Lazy.fromChunks
-            [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
-            , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
-            ]
-  ------------------------------------------------------------------------------
+defaultSymName ∷ ModName → Name
+defaultSymName = headToLower ∘ getLastComp
+    where
+      headToLower ∷ String → Name
+      headToLower []     = error "module name must not be empty"
+      headToLower (x:xs) = mkName (toLower x:xs)
 
-  壓縮される場合は次のやうに變はる:
-  ------------------------------------------------------------------------------
-  -- import に追加
-  import Codec.Compression.GZip
+      getLastComp ∷ ModName → String
+      getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse ∘ modString
 
-  -- ResourceDef は次のやうに變化
-  baz ∷ ResourceDef
-  baz = ResourceDef {
-          resUsesNativeThread = False
-        , resIsGreedy         = False
-        , resGet
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
+generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
+generateHaskellSource opts srcFile
+    = do i   ← openInput srcFile (getMIMEType opts) (getETag opts)
+         o   ← openOutput opts
+         doc ← pprInput i modName symName
+         hPutStrLn o ∘ show $ to_HPJ_Doc doc
+         hClose o
+    where
+      modName ∷ ModName
+      modName = getModuleName opts
 
-                        gzip ← isEncodingAcceptable "gzip"
-                        if gzip then
-                            do setContentEncoding ["gzip"]
-                               output gzippedData
-                        else
-                            output (decompress gzippedData)
-        , resHead
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
-        , resPost   = Nothing
-        , resPut    = Nothing
-        , resDelete = Nothing
-        }
-  
-  -- rawData の代はりに gzippedData
-  gzippedData ∷ Lazy.ByteString
-  gzippedData = Lazy.fromChunks
-                [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
-                , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
-                ]
-  ------------------------------------------------------------------------------
- -}
+      symName ∷ Name
+      symName = fromMaybe (defaultSymName modName)
+                $ getSymbolName opts