git.iko.soy/elk
on 8f7c3cd help sign in
elk/cli/src/Develop.hs
266 lines 6.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Develop (run) where
5import Control.Applicative ((<|>))
6import Control.Concurrent (threadDelay)
7import Control.Monad (guard)
8import Control.Monad.Trans (MonadIO(liftIO))
9import qualified Data.HashMap.Strict as HashMap
10import qualified Data.ByteString.Char8 as BSC
11import System.Directory
12import System.FilePath
13import Snap.Core
14import Snap.Http.Server
15import Snap.Util.FileServe
16import qualified Text.Blaze.Html5 as H
17import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
19import qualified CommandLine.Args as Args
20import qualified Develop.Compile as Compile
21import qualified Develop.Generate.Help as Generate
22import qualified Develop.Generate.Index as Index
23import qualified Develop.Generate.NotFound as NotFound
24import qualified Develop.StaticFiles as StaticFiles
28-- RUN THE DEV SERVER
31run :: Args.DevFlags -> IO ()
32run (Args.DevFlags maybePort) =
33 -- TODO get `elm reactor` running again
34 if True then
35 putStrLn $
36 "The reactor is not available in the ALPHA period.\n\
37 \\n\
38 \The goal is for package authors to get code updated and give early feedback.\n\
39 \Professionals and hobbyists should NOT be ugrading at this time!\n"
40 else
41 let
42 port =
43 maybe 8000 id maybePort
44 in
45 do putStrLn (startupMessage port)
47 httpServe (config port) $
48 serveFiles
49 <|> route [ ("_compile", compile) ]
50 <|> route [ ("_elm/move-to-root", moveToRoot)]
51 <|> route [ ("_elm/create-new-project", createNewProject)]
52 <|> serveDirectoryWith directoryConfig "."
53 <|> serveAssets
54 <|> error404
57config :: Int -> Config Snap a
58config port =
59 defaultConfig
60 # setVerbose False
61 # setPort port
62 # setAccessLog ConfigNoLog
63 # setErrorLog ConfigNoLog
66(#) :: a -> (a -> b) -> b
67(#) value func =
68 func value
72-- HELPERS
75startupMessage :: Int -> String
76startupMessage port =
77 "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."
80directoryConfig :: MonadSnap m => DirectoryConfig m
81directoryConfig =
82 let
83 customGenerator directory =
84 do project <- liftIO (Index.getProject directory)
85 modifyResponse $ setContentType "text/html; charset=utf-8"
86 writeBuilder (Blaze.renderHtmlBuilder (Index.toHtml project))
87 in
88 fancyDirectoryConfig
89 { indexFiles = []
90 , indexGenerator = customGenerator
91 }
94compile :: Snap ()
95compile =
96 do file <- getSafePath
97 guard =<< liftIO (doesFileExist file)
98 modifyResponse (setContentType "text/javascript")
99 writeBS =<< liftIO (Compile.toJavaScript file)
102error404 :: Snap ()
103error404 =
104 do modifyResponse $ setResponseStatus 404 "Not Found"
105 modifyResponse $ setContentType "text/html; charset=utf-8"
106 writeBuilder (Blaze.renderHtmlBuilder NotFound.html)
110-- CREATE NEW PROJECT
113createNewProject :: Snap ()
114createNewProject =
115 do liftIO $ threadDelay (2 * 1000 * 1000)
116 return ()
119moveToRoot :: Snap ()
120moveToRoot =
121 liftIO Index.moveToRoot
125-- SERVE FILES
128serveFiles :: Snap ()
129serveFiles =
130 do file <- getSafePath
131 guard =<< liftIO (doesFileExist file)
132 serveElm file <|> serveFilePretty file
135serveHtml :: MonadSnap m => H.Html -> m ()
136serveHtml html =
137 do modifyResponse (setContentType "text/html")
138 writeBuilder (Blaze.renderHtmlBuilder html)
142-- SERVE FILES + CODE HIGHLIGHTING
145serveFilePretty :: FilePath -> Snap ()
146serveFilePretty file =
147 let
148 possibleExtensions =
149 getSubExts (takeExtensions file)
150 in
151 case mconcat (map lookupMimeType possibleExtensions) of
152 Nothing ->
153 serveCode file
155 Just mimeType ->
156 serveFileAs mimeType file
159getSubExts :: String -> [String]
160getSubExts fullExtension =
161 if null fullExtension then
162 []
164 else
165 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
168serveCode :: String -> Snap ()
169serveCode file =
170 do code <- liftIO (readFile file)
171 serveHtml $ Generate.makeCodeHtml ('~' : '/' : file) code
175-- SERVE ELM
178serveElm :: FilePath -> Snap ()
179serveElm file =
180 do guard (takeExtension file == ".elm")
181 serveHtml (Generate.makeElmHtml file)
185-- SERVE STATIC ASSETS
188serveAssets :: Snap ()
189serveAssets =
190 do file <- getSafePath
191 case StaticFiles.lookup file of
192 Nothing ->
193 pass
195 Just (content, mimeType) ->
196 do modifyResponse (setContentType $ BSC.pack (mimeType ++ ";charset=utf-8"))
197 writeBS content
201-- MIME TYPES
204lookupMimeType :: FilePath -> Maybe BSC.ByteString
205lookupMimeType ext =
206 HashMap.lookup ext mimeTypeDict
209(==>) :: a -> b -> (a,b)
210(==>) a b =
211 (a, b)
214mimeTypeDict :: HashMap.HashMap FilePath BSC.ByteString
215mimeTypeDict =
216 HashMap.fromList
217 [ ".asc" ==> "text/plain"
218 , ".asf" ==> "video/x-ms-asf"
219 , ".asx" ==> "video/x-ms-asf"
220 , ".avi" ==> "video/x-msvideo"
221 , ".bz2" ==> "application/x-bzip"
222 , ".css" ==> "text/css"
223 , ".dtd" ==> "text/xml"
224 , ".dvi" ==> "application/x-dvi"
225 , ".gif" ==> "image/gif"
226 , ".gz" ==> "application/x-gzip"
227 , ".htm" ==> "text/html"
228 , ".html" ==> "text/html"
229 , ".ico" ==> "image/x-icon"
230 , ".jpeg" ==> "image/jpeg"
231 , ".jpg" ==> "image/jpeg"
232 , ".js" ==> "text/javascript"
233 , ".json" ==> "application/json"
234 , ".m3u" ==> "audio/x-mpegurl"
235 , ".mov" ==> "video/quicktime"
236 , ".mp3" ==> "audio/mpeg"
237 , ".mpeg" ==> "video/mpeg"
238 , ".mpg" ==> "video/mpeg"
239 , ".ogg" ==> "application/ogg"
240 , ".pac" ==> "application/x-ns-proxy-autoconfig"
241 , ".pdf" ==> "application/pdf"
242 , ".png" ==> "image/png"
243 , ".qt" ==> "video/quicktime"
244 , ".sig" ==> "application/pgp-signature"
245 , ".spl" ==> "application/futuresplash"
246 , ".svg" ==> "image/svg+xml"
247 , ".swf" ==> "application/x-shockwave-flash"
248 , ".tar" ==> "application/x-tar"
249 , ".tar.bz2" ==> "application/x-bzip-compressed-tar"
250 , ".tar.gz" ==> "application/x-tgz"
251 , ".tbz" ==> "application/x-bzip-compressed-tar"
252 , ".text" ==> "text/plain"
253 , ".tgz" ==> "application/x-tgz"
254 , ".ttf" ==> "application/x-font-truetype"
255 , ".txt" ==> "text/plain"
256 , ".wav" ==> "audio/x-wav"
257 , ".wax" ==> "audio/x-ms-wax"
258 , ".wma" ==> "audio/x-ms-wma"
259 , ".wmv" ==> "video/x-ms-wmv"
260 , ".xbm" ==> "image/x-xbitmap"
261 , ".xml" ==> "text/xml"
262 , ".xpm" ==> "image/x-xpixmap"
263 , ".xwd" ==> "image/x-xwindowdump"
264 , ".zip" ==> "application/zip"
265 ]