git.iko.soy/elk
on 253bb13 help sign in
elk/terminal/src/Develop.hs
263 lines 6.5 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Develop
3 ( Flags(..)
4 , run
5 )
6 where
9import Control.Applicative ((<|>))
10import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
11import Control.Monad (guard, void)
12import Control.Monad.Trans (MonadIO(liftIO))
13import qualified Data.ByteString.Builder as B
14import qualified Data.ByteString as BS
15import qualified Data.HashMap.Strict as HashMap
16import Data.Monoid ((<>))
17import qualified System.Directory as Dir
18import System.FilePath as FP
19import Snap.Core
20import Snap.Http.Server
21import Snap.Util.FileServe
23import qualified Elm.Project as Project
24import qualified Develop.Generate.Help as Generate
25import qualified Develop.Generate.Index as Index
26import qualified Develop.StaticFiles as StaticFiles
27import qualified Generate.Output as Output
28import qualified Reporting.Exit as Exit
29import qualified Reporting.Progress as Progress
30import qualified Reporting.Task as Task
34-- RUN THE DEV SERVER
37data Flags =
38 Flags
39 { _port :: Maybe Int
40 }
43run :: () -> Flags -> IO ()
44run () (Flags maybePort) =
45 let
46 port =
47 maybe 8000 id maybePort
48 in
49 do putStrLn $ "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."
51 httpServe (config port) $
52 serveFiles
53 <|> serveDirectoryWith directoryConfig "."
54 <|> serveAssets
55 <|> error404
58config :: Int -> Config Snap a
59config port =
60 defaultConfig
61 # setVerbose False
62 # setPort port
63 # setAccessLog ConfigNoLog
64 # setErrorLog ConfigNoLog
67(#) :: a -> (a -> b) -> b
68(#) value func =
69 func value
73-- INDEX
76directoryConfig :: MonadSnap m => DirectoryConfig m
77directoryConfig =
78 let
79 customGenerator pwd =
80 do modifyResponse $ setContentType "text/html; charset=utf-8"
81 html <- liftIO $
82 do root <- Dir.getCurrentDirectory
83 Index.get root pwd
84 writeBuilder html
85 in
86 fancyDirectoryConfig
87 { indexFiles = []
88 , indexGenerator = customGenerator
89 }
93-- NOT FOUND
96error404 :: Snap ()
97error404 =
98 do modifyResponse $ setResponseStatus 404 "Not Found"
99 modifyResponse $ setContentType "text/html; charset=utf-8"
100 writeBuilder $ Generate.makePageHtml "NotFound" Nothing
104-- SERVE FILES
107serveFiles :: Snap ()
108serveFiles =
109 do file <- getSafePath
110 guard =<< liftIO (Dir.doesFileExist file)
111 serveElm file <|> serveFilePretty file
115-- SERVE FILES + CODE HIGHLIGHTING
118serveFilePretty :: FilePath -> Snap ()
119serveFilePretty file =
120 let
121 possibleExtensions =
122 getSubExts (takeExtensions file)
123 in
124 case mconcat (map lookupMimeType possibleExtensions) of
125 Nothing ->
126 serveCode file
128 Just mimeType ->
129 serveFileAs mimeType file
132getSubExts :: String -> [String]
133getSubExts fullExtension =
134 if null fullExtension then
135 []
137 else
138 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
141serveCode :: String -> Snap ()
142serveCode file =
143 do code <- liftIO (BS.readFile file)
144 modifyResponse (setContentType "text/html")
145 writeBuilder $
146 Generate.makeCodeHtml ('~' : '/' : file) (B.byteString code)
150-- SERVE ELM
153serveElm :: FilePath -> Snap ()
154serveElm file =
155 do guard (takeExtension file == ".elm")
156 modifyResponse (setContentType "text/html")
157 writeBuilder =<< liftIO (compileToHtmlBuilder file)
160compileToHtmlBuilder :: FilePath -> IO B.Builder
161compileToHtmlBuilder file =
162 do mvar1 <- newEmptyMVar
163 mvar2 <- newEmptyMVar
165 let reporter = Progress.Reporter (\_ -> return ()) (\_ -> return True) (putMVar mvar1)
166 let output = Just (Output.HtmlBuilder mvar2)
168 void $ Task.try reporter $
169 do summary <- Project.getRoot
170 Project.compile Output.Dev Output.Client output summary [file]
172 result <- takeMVar mvar1
173 case result of
174 Just exit ->
175 return $ Generate.makePageHtml "Errors" (Just (Exit.toJson exit))
177 Nothing ->
178 takeMVar mvar2
182-- SERVE STATIC ASSETS
185serveAssets :: Snap ()
186serveAssets =
187 do file <- getSafePath
188 case StaticFiles.lookup file of
189 Nothing ->
190 pass
192 Just (content, mimeType) ->
193 do modifyResponse (setContentType (mimeType <> ";charset=utf-8"))
194 writeBS content
198-- MIME TYPES
201lookupMimeType :: FilePath -> Maybe BS.ByteString
202lookupMimeType ext =
203 HashMap.lookup ext mimeTypeDict
206(==>) :: a -> b -> (a,b)
207(==>) a b =
208 (a, b)
211mimeTypeDict :: HashMap.HashMap FilePath BS.ByteString
212mimeTypeDict =
213 HashMap.fromList
214 [ ".asc" ==> "text/plain"
215 , ".asf" ==> "video/x-ms-asf"
216 , ".asx" ==> "video/x-ms-asf"
217 , ".avi" ==> "video/x-msvideo"
218 , ".bz2" ==> "application/x-bzip"
219 , ".css" ==> "text/css"
220 , ".dtd" ==> "text/xml"
221 , ".dvi" ==> "application/x-dvi"
222 , ".gif" ==> "image/gif"
223 , ".gz" ==> "application/x-gzip"
224 , ".htm" ==> "text/html"
225 , ".html" ==> "text/html"
226 , ".ico" ==> "image/x-icon"
227 , ".jpeg" ==> "image/jpeg"
228 , ".jpg" ==> "image/jpeg"
229 , ".js" ==> "text/javascript"
230 , ".json" ==> "application/json"
231 , ".m3u" ==> "audio/x-mpegurl"
232 , ".mov" ==> "video/quicktime"
233 , ".mp3" ==> "audio/mpeg"
234 , ".mpeg" ==> "video/mpeg"
235 , ".mpg" ==> "video/mpeg"
236 , ".ogg" ==> "application/ogg"
237 , ".pac" ==> "application/x-ns-proxy-autoconfig"
238 , ".pdf" ==> "application/pdf"
239 , ".png" ==> "image/png"
240 , ".qt" ==> "video/quicktime"
241 , ".sig" ==> "application/pgp-signature"
242 , ".spl" ==> "application/futuresplash"
243 , ".svg" ==> "image/svg+xml"
244 , ".swf" ==> "application/x-shockwave-flash"
245 , ".tar" ==> "application/x-tar"
246 , ".tar.bz2" ==> "application/x-bzip-compressed-tar"
247 , ".tar.gz" ==> "application/x-tgz"
248 , ".tbz" ==> "application/x-bzip-compressed-tar"
249 , ".text" ==> "text/plain"
250 , ".tgz" ==> "application/x-tgz"
251 , ".ttf" ==> "application/x-font-truetype"
252 , ".txt" ==> "text/plain"
253 , ".wav" ==> "audio/x-wav"
254 , ".wax" ==> "audio/x-ms-wax"
255 , ".wma" ==> "audio/x-ms-wma"
256 , ".wmv" ==> "video/x-ms-wmv"
257 , ".xbm" ==> "image/x-xbitmap"
258 , ".xml" ==> "text/xml"
259 , ".xpm" ==> "image/x-xpixmap"
260 , ".xwd" ==> "image/x-xwindowdump"
261 , ".zip" ==> "application/zip"
262 ]