Unfoldable Dispatcher
[Lucu.git] / 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