ImplantFile.hs

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