{-# LANGUAGE UnicodeSyntax #-} module Main (main) where import Control.Applicative import Control.Monad import qualified Data.Ascii as A import Data.Char import Data.Maybe 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 Prelude.Unicode import System.Console.GetOpt import System.Environment import System.Exit import System.IO data CmdOpt = OptOutput FilePath | OptModName String | OptSymName String | OptMIMEType String | OptETag String | OptHelp deriving (Eq, Show) options ∷ [OptDescr CmdOpt] options = [ Option "o" ["output"] (ReqArg OptOutput "FILE") "Output to the FILE." , Option "m" ["module"] (ReqArg OptModName "MODULE") "Specify the resulting module name. (required)" , Option "s" ["symbol"] (ReqArg OptSymName "SYMBOL") "Specify the resulting symbol name." , Option "t" ["mime-type"] (ReqArg OptMIMEType "TYPE") "Specify the MIME Type of the file." , Option "e" ["etag"] (ReqArg OptETag "TAG") "Specify the ETag of the file." , Option "h" ["help"] (NoArg OptHelp) "Print this message." ] printUsage ∷ IO () printUsage = do mapM_ putStrLn msg putStr $ usageInfo "Options:" options putStrLn "" where msg = [ "" , "Description:" , 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." ] , "" , "Usage:" , " lucu-implant-file [OPTIONS...] FILE" , "" ] main ∷ IO () main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs unless (null errors) $ do mapM_ putStr errors exitWith $ ExitFailure 1 when (any (≡ OptHelp) opts) $ do printUsage exitWith ExitSuccess when (null sources) $ do printUsage exitWith $ ExitFailure 1 when (length sources ≥ 2) $ fail "too many input files." generateHaskellSource opts (head sources) getMIMEType ∷ [CmdOpt] → Maybe MIMEType getMIMEType opts = case mimeTypeOpts of [] → 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 = filter (\ x → case x of OptMIMEType _ → True _ → False) opts getETag ∷ [CmdOpt] → Maybe ETag getETag opts = case eTagOpts of [] → Nothing OptETag str:[] → Just $ strToETag str _ → error "too many --etag options." where 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 = 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 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 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) getLastComp ∷ ModName → String getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse ∘ modString 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 symName ∷ Name symName = fromMaybe (defaultSymName modName) $ getSymbolName opts