git.iko.soy/elk
on 1c91efd help sign in
elk/terminal/src/Develop.hs
264 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 Json.Encode as Encode
29import qualified Reporting.Exit as Exit
30import qualified Reporting.Progress as Progress
31import qualified Reporting.Task as Task
35-- RUN THE DEV SERVER
38data Flags =
39 Flags
40 { _port :: Maybe Int
41 }
44run :: () -> Flags -> IO ()
45run () (Flags maybePort) =
46 let
47 port =
48 maybe 8000 id maybePort
49 in
50 do putStrLn $ "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."
52 httpServe (config port) $
53 serveFiles
54 <|> serveDirectoryWith directoryConfig "."
55 <|> serveAssets
56 <|> error404
59config :: Int -> Config Snap a
60config port =
61 defaultConfig
62 # setVerbose False
63 # setPort port
64 # setAccessLog ConfigNoLog
65 # setErrorLog ConfigNoLog
68(#) :: a -> (a -> b) -> b
69(#) value func =
70 func value
74-- INDEX
77directoryConfig :: MonadSnap m => DirectoryConfig m
78directoryConfig =
79 let
80 customGenerator pwd =
81 do modifyResponse $ setContentType "text/html; charset=utf-8"
82 html <- liftIO $
83 do root <- Dir.getCurrentDirectory
84 Index.get root pwd
85 writeBuilder html
86 in
87 fancyDirectoryConfig
88 { indexFiles = []
89 , indexGenerator = customGenerator
90 }
94-- NOT FOUND
97error404 :: Snap ()
98error404 =
99 do modifyResponse $ setResponseStatus 404 "Not Found"
100 modifyResponse $ setContentType "text/html; charset=utf-8"
101 writeBuilder $ Generate.makePageHtml "NotFound" Nothing
105-- SERVE FILES
108serveFiles :: Snap ()
109serveFiles =
110 do file <- getSafePath
111 guard =<< liftIO (Dir.doesFileExist file)
112 serveElm file <|> serveFilePretty file
116-- SERVE FILES + CODE HIGHLIGHTING
119serveFilePretty :: FilePath -> Snap ()
120serveFilePretty file =
121 let
122 possibleExtensions =
123 getSubExts (takeExtensions file)
124 in
125 case mconcat (map lookupMimeType possibleExtensions) of
126 Nothing ->
127 serveCode file
129 Just mimeType ->
130 serveFileAs mimeType file
133getSubExts :: String -> [String]
134getSubExts fullExtension =
135 if null fullExtension then
136 []
138 else
139 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
142serveCode :: String -> Snap ()
143serveCode file =
144 do code <- liftIO (BS.readFile file)
145 modifyResponse (setContentType "text/html")
146 writeBuilder $
147 Generate.makeCodeHtml ('~' : '/' : file) (B.byteString code)
151-- SERVE ELM
154serveElm :: FilePath -> Snap ()
155serveElm file =
156 do guard (takeExtension file == ".elm")
157 modifyResponse (setContentType "text/html")
158 writeBuilder =<< liftIO (compileToHtmlBuilder file)
161compileToHtmlBuilder :: FilePath -> IO B.Builder
162compileToHtmlBuilder file =
163 do mvar1 <- newEmptyMVar
164 mvar2 <- newEmptyMVar
166 let reporter = Progress.Reporter (\_ -> return ()) (\_ -> return True) (putMVar mvar1)
167 let output = Just (Output.HtmlBuilder mvar2)
169 void $ Task.try reporter $
170 do summary <- Project.getRoot
171 Project.compile Output.Dev Output.Client output Nothing summary [file]
173 result <- takeMVar mvar1
174 case result of
175 Just exit ->
176 return $ Generate.makePageHtml "Errors" (Just (Exit.toJson exit))
178 Nothing ->
179 takeMVar mvar2
183-- SERVE STATIC ASSETS
186serveAssets :: Snap ()
187serveAssets =
188 do file <- getSafePath
189 case StaticFiles.lookup file of
190 Nothing ->
191 pass
193 Just (content, mimeType) ->
194 do modifyResponse (setContentType (mimeType <> ";charset=utf-8"))
195 writeBS content
199-- MIME TYPES
202lookupMimeType :: FilePath -> Maybe BS.ByteString
203lookupMimeType ext =
204 HashMap.lookup ext mimeTypeDict
207(==>) :: a -> b -> (a,b)
208(==>) a b =
209 (a, b)
212mimeTypeDict :: HashMap.HashMap FilePath BS.ByteString
213mimeTypeDict =
214 HashMap.fromList
215 [ ".asc" ==> "text/plain"
216 , ".asf" ==> "video/x-ms-asf"
217 , ".asx" ==> "video/x-ms-asf"
218 , ".avi" ==> "video/x-msvideo"
219 , ".bz2" ==> "application/x-bzip"
220 , ".css" ==> "text/css"
221 , ".dtd" ==> "text/xml"
222 , ".dvi" ==> "application/x-dvi"
223 , ".gif" ==> "image/gif"
224 , ".gz" ==> "application/x-gzip"
225 , ".htm" ==> "text/html"
226 , ".html" ==> "text/html"
227 , ".ico" ==> "image/x-icon"
228 , ".jpeg" ==> "image/jpeg"
229 , ".jpg" ==> "image/jpeg"
230 , ".js" ==> "text/javascript"
231 , ".json" ==> "application/json"
232 , ".m3u" ==> "audio/x-mpegurl"
233 , ".mov" ==> "video/quicktime"
234 , ".mp3" ==> "audio/mpeg"
235 , ".mpeg" ==> "video/mpeg"
236 , ".mpg" ==> "video/mpeg"
237 , ".ogg" ==> "application/ogg"
238 , ".pac" ==> "application/x-ns-proxy-autoconfig"
239 , ".pdf" ==> "application/pdf"
240 , ".png" ==> "image/png"
241 , ".qt" ==> "video/quicktime"
242 , ".sig" ==> "application/pgp-signature"
243 , ".spl" ==> "application/futuresplash"
244 , ".svg" ==> "image/svg+xml"
245 , ".swf" ==> "application/x-shockwave-flash"
246 , ".tar" ==> "application/x-tar"
247 , ".tar.bz2" ==> "application/x-bzip-compressed-tar"
248 , ".tar.gz" ==> "application/x-tgz"
249 , ".tbz" ==> "application/x-bzip-compressed-tar"
250 , ".text" ==> "text/plain"
251 , ".tgz" ==> "application/x-tgz"
252 , ".ttf" ==> "application/x-font-truetype"
253 , ".txt" ==> "text/plain"
254 , ".wav" ==> "audio/x-wav"
255 , ".wax" ==> "audio/x-ms-wax"
256 , ".wma" ==> "audio/x-ms-wma"
257 , ".wmv" ==> "video/x-ms-wmv"
258 , ".xbm" ==> "image/x-xbitmap"
259 , ".xml" ==> "text/xml"
260 , ".xpm" ==> "image/x-xpixmap"
261 , ".xwd" ==> "image/x-xwindowdump"
262 , ".zip" ==> "application/zip"
263 ]