ImplantFile.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 module Main (main) where
   5 import Control.Applicative
   6 import Control.Monad
   7 import qualified Data.Ascii as A
   8 import Data.Char
   9 import Data.Maybe
  10 import Language.Haskell.TH.PprLib
  11 import Language.Haskell.TH.Syntax
  12 import Network.HTTP.Lucu.ETag
  13 import Network.HTTP.Lucu.Implant
  14 import Network.HTTP.Lucu.Implant.PrettyPrint
  15 import Network.HTTP.Lucu.MIMEType
  16 import Prelude.Unicode
  17 import System.Console.GetOpt
  18 import System.Environment
  19 import System.Exit
  20 import System.IO
  21
  22 data CmdOpt
  23     = OptOutput FilePath
  24     | OptModName String
  25     | OptSymName String
  26     | OptMIMEType String
  27     | OptETag String
  28     | OptHelp
  29     deriving (Eq, Show)
  30
  31 options ∷ [OptDescr CmdOpt]
  32 options = [ Option "o" ["output"]
  33                        (ReqArg OptOutput "FILE")
  34                        "Output to the FILE."
  35
  36           , Option "m" ["module"]
  37                        (ReqArg OptModName "MODULE")
  38                        "Specify the resulting module name. (required)"
  39
  40           , Option "s" ["symbol"]
  41                        (ReqArg OptSymName "SYMBOL")
  42                        "Specify the resulting symbol name."
  43
  44           , Option "t" ["mime-type"]
  45                        (ReqArg OptMIMEType "TYPE")
  46                        "Specify the MIME Type of the file."
  47
  48           , Option "e" ["etag"]
  49                        (ReqArg OptETag "TAG")
  50                        "Specify the ETag of the file."
  51
  52           , Option "h" ["help"]
  53                        (NoArg OptHelp)
  54                        "Print this message."
  55           ]
  56
  57 printUsage ∷ IO ()
  58 printUsage = do mapM_ putStrLn msg
  59                 putStr $ usageInfo "Options:" options
  60                 putStrLn ""
  61     where
  62       msg = [ ""
  63             , "Description:"
  64             , concat [ "  lucu-implant-file is an utility that generates "
  65                      , "Haskell code containing an arbitrary file to "
  66                      , "compile it directly into programs and serve it "
  67                      , "statically with the Lucu HTTP server."
  68                      ]
  69             , ""
  70             , "Usage:"
  71             , "  lucu-implant-file [OPTIONS...] FILE"
  72             , ""
  73             ]
  74
  75 main ∷ IO ()
  76 main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
  77
  78           unless (null errors)
  79               $ do mapM_ putStr errors
  80                    exitWith $ ExitFailure 1
  81
  82           when (any (≡ OptHelp) opts)
  83               $ do printUsage
  84                    exitWith ExitSuccess
  85
  86           when (null sources)
  87                $ do printUsage
  88                     exitWith $ ExitFailure 1
  89
  90           when (length sources ≥ 2)
  91                $ fail "too many input files."
  92
  93           generateHaskellSource opts (head sources)
  94
  95 getMIMEType ∷ [CmdOpt] → Maybe MIMEType
  96 getMIMEType opts
  97     = case mimeTypeOpts of
  98         []  → Nothing
  99         OptMIMEType ty:[]
 100             → case A.fromChars ty of
 101                  Just a  → Just $ parseMIMEType a
 102                  Nothing → error "MIME types must not contain any non-ASCII letters."
 103         _   → error "too many --mime-type options."
 104     where
 105       mimeTypeOpts ∷ [CmdOpt]
 106       mimeTypeOpts
 107           = filter (\ x → case x of
 108                              OptMIMEType _ → True
 109                              _             → False) opts
 110
 111 getETag ∷ [CmdOpt] → Maybe ETag
 112 getETag opts
 113     = case eTagOpts of
 114         []             → Nothing
 115         OptETag str:[] → Just $ strToETag str
 116         _              → error "too many --etag options."
 117     where
 118       eTagOpts ∷ [CmdOpt]
 119       eTagOpts = filter (\ x → case x of
 120                                   OptETag _ → True
 121                                   _         → False) opts
 122
 123       strToETag ∷ String → ETag
 124       strToETag str
 125           = case A.fromChars str of
 126               Just a  → strongETag a
 127               Nothing → error "ETag must not contain any non-ASCII letters."
 128
 129 openOutput ∷ [CmdOpt] → IO Handle
 130 openOutput opts
 131     = case outputOpts of
 132         []                 → return stdout
 133         OptOutput fpath:[] → do h ← openFile fpath WriteMode
 134                                 hSetEncoding h utf8
 135                                 return h
 136         _                  → fail "two many --output options."
 137     where
 138       outputOpts ∷ [CmdOpt]
 139       outputOpts = filter (\ x → case x of
 140                                     OptOutput _ → True
 141                                     _           → False) opts
 142
 143 getModuleName ∷ [CmdOpt] → ModName
 144 getModuleName opts
 145     = case modNameOpts of
 146         []                 → error "a module name must be given."
 147         OptModName name:[] → mkModName name
 148         _                  → error "too many --module options."
 149     where
 150       modNameOpts ∷ [CmdOpt]
 151       modNameOpts = filter (\ x → case x of
 152                                      OptModName _ → True
 153                                      _            → False) opts
 154
 155 getSymbolName ∷ [CmdOpt] → Maybe Name
 156 getSymbolName opts
 157     = case symNameOpts of
 158         []                 → Nothing
 159         OptSymName name:[] → Just $ mkName name
 160         _                  → fail "too many --symbol options."
 161     where
 162       symNameOpts ∷ [CmdOpt]
 163       symNameOpts = filter (\ x → case x of
 164                                      OptSymName _ → True
 165                                      _            → False) opts
 166
 167 defaultSymName ∷ ModName → Name
 168 defaultSymName = headToLower ∘ getLastComp
 169     where
 170       headToLower ∷ String → Name
 171       headToLower []     = error "module name must not be empty"
 172       headToLower (x:xs) = mkName (toLower x:xs)
 173
 174       getLastComp ∷ ModName → String
 175       getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse ∘ modString
 176
 177 generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
 178 generateHaskellSource opts srcFile
 179     = do i   ← openInput srcFile (getMIMEType opts) (getETag opts)
 180          o   ← openOutput opts
 181          doc ← pprInput i modName symName
 182          hPutStrLn o ∘ show $ to_HPJ_Doc doc
 183          hClose o
 184     where
 185       modName ∷ ModName
 186       modName = getModuleName opts
 187
 188       symName ∷ Name
 189       symName = fromMaybe (defaultSymName modName)
 190                 $ getSymbolName opts