git.iko.soy/elk
on f4401ac help sign in
elk/terminal/src/Develop.hs
242 lines 6.4 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Develop
3 ( Flags(..)
4 , run
5 )
6 where
9import Control.Applicative ((<|>))
10import Control.Monad (guard)
11import Control.Monad.Trans (MonadIO(liftIO))
12import qualified Data.ByteString.Builder as B
13import qualified Data.ByteString as BS
14import qualified Data.HashMap.Strict as HashMap
15import Data.Monoid ((<>))
16import qualified Data.NonEmptyList as NE
17import qualified System.Directory as Dir
18import System.FilePath as FP
19import Snap.Core hiding (path)
20import Snap.Http.Server
21import Snap.Util.FileServe
23import qualified Build
24import qualified Elm.Details as Details
25import qualified Develop.Generate.Help as Help
26import qualified Develop.Generate.Index as Index
27import qualified Develop.StaticFiles as StaticFiles
28import qualified Generate.Html as Html
29import qualified Generate
30import qualified Reporting
31import qualified Reporting.Exit as Exit
32import qualified Reporting.Task as Task
33import qualified Stuff
37-- RUN THE DEV SERVER
40data Flags =
41 Flags
42 { _port :: Maybe Int
43 }
46run :: () -> Flags -> IO ()
47run () (Flags maybePort) =
48 do let port = maybe 8000 id maybePort
49 putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard."
50 httpServe (config port) $
51 serveFiles
52 <|> serveDirectoryWith directoryConfig "."
53 <|> serveAssets
54 <|> error404
57config :: Int -> Config Snap a
58config port =
59 setVerbose False $ setPort port $
60 setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
64-- INDEX
67directoryConfig :: MonadSnap m => DirectoryConfig m
68directoryConfig =
69 fancyDirectoryConfig
70 { indexFiles = []
71 , indexGenerator = \pwd ->
72 do modifyResponse $ setContentType "text/html;charset=utf-8"
73 writeBuilder =<< liftIO (Index.generate pwd)
74 }
78-- NOT FOUND
81error404 :: Snap ()
82error404 =
83 do modifyResponse $ setResponseStatus 404 "Not Found"
84 modifyResponse $ setContentType "text/html;charset=utf-8"
85 writeBuilder $ Help.makePageHtml "NotFound" Nothing
89-- SERVE FILES
92serveFiles :: Snap ()
93serveFiles =
94 do path <- getSafePath
95 guard =<< liftIO (Dir.doesFileExist path)
96 serveElm path <|> serveFilePretty path
100-- SERVE FILES + CODE HIGHLIGHTING
103serveFilePretty :: FilePath -> Snap ()
104serveFilePretty path =
105 let
106 possibleExtensions =
107 getSubExts (takeExtensions path)
108 in
109 case mconcat (map lookupMimeType possibleExtensions) of
110 Nothing ->
111 serveCode path
113 Just mimeType ->
114 serveFileAs mimeType path
117getSubExts :: String -> [String]
118getSubExts fullExtension =
119 if null fullExtension then
120 []
121 else
122 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
125serveCode :: String -> Snap ()
126serveCode path =
127 do code <- liftIO (BS.readFile path)
128 modifyResponse (setContentType "text/html")
129 writeBuilder $
130 Help.makeCodeHtml ('~' : '/' : path) (B.byteString code)
134-- SERVE ELM
137serveElm :: FilePath -> Snap ()
138serveElm path =
139 do guard (takeExtension path == ".elm")
140 modifyResponse (setContentType "text/html")
141 result <- liftIO $ Task.run $ compile path
142 case result of
143 Right builder ->
144 writeBuilder builder
146 Left exit ->
147 writeBuilder $ Help.makePageHtml "Errors" $ Just $
148 Exit.toJson $ Exit.reactorToReport exit
151compile :: FilePath -> Task.Task Exit.Reactor B.Builder
152compile path =
153 do root <- Task.mio Exit.ReactorNoOutline Stuff.findRoot
154 details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent root
155 artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromMains Reporting.silent root details (NE.List path [])
156 javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts
157 let (NE.List name _) = Build.getMainNames artifacts
158 return $ Html.sandwich name javascript
162-- SERVE STATIC ASSETS
165serveAssets :: Snap ()
166serveAssets =
167 do path <- getSafePath
168 case StaticFiles.lookup path of
169 Nothing ->
170 pass
172 Just (content, mimeType) ->
173 do modifyResponse (setContentType (mimeType <> ";charset=utf-8"))
174 writeBS content
178-- MIME TYPES
181lookupMimeType :: FilePath -> Maybe BS.ByteString
182lookupMimeType ext =
183 HashMap.lookup ext mimeTypeDict
186(==>) :: a -> b -> (a,b)
187(==>) a b =
188 (a, b)
191mimeTypeDict :: HashMap.HashMap FilePath BS.ByteString
192mimeTypeDict =
193 HashMap.fromList
194 [ ".asc" ==> "text/plain"
195 , ".asf" ==> "video/x-ms-asf"
196 , ".asx" ==> "video/x-ms-asf"
197 , ".avi" ==> "video/x-msvideo"
198 , ".bz2" ==> "application/x-bzip"
199 , ".css" ==> "text/css"
200 , ".dtd" ==> "text/xml"
201 , ".dvi" ==> "application/x-dvi"
202 , ".gif" ==> "image/gif"
203 , ".gz" ==> "application/x-gzip"
204 , ".htm" ==> "text/html"
205 , ".html" ==> "text/html"
206 , ".ico" ==> "image/x-icon"
207 , ".jpeg" ==> "image/jpeg"
208 , ".jpg" ==> "image/jpeg"
209 , ".js" ==> "text/javascript"
210 , ".json" ==> "application/json"
211 , ".m3u" ==> "audio/x-mpegurl"
212 , ".mov" ==> "video/quicktime"
213 , ".mp3" ==> "audio/mpeg"
214 , ".mpeg" ==> "video/mpeg"
215 , ".mpg" ==> "video/mpeg"
216 , ".ogg" ==> "application/ogg"
217 , ".pac" ==> "application/x-ns-proxy-autoconfig"
218 , ".pdf" ==> "application/pdf"
219 , ".png" ==> "image/png"
220 , ".qt" ==> "video/quicktime"
221 , ".sig" ==> "application/pgp-signature"
222 , ".spl" ==> "application/futuresplash"
223 , ".svg" ==> "image/svg+xml"
224 , ".swf" ==> "application/x-shockwave-flash"
225 , ".tar" ==> "application/x-tar"
226 , ".tar.bz2" ==> "application/x-bzip-compressed-tar"
227 , ".tar.gz" ==> "application/x-tgz"
228 , ".tbz" ==> "application/x-bzip-compressed-tar"
229 , ".text" ==> "text/plain"
230 , ".tgz" ==> "application/x-tgz"
231 , ".ttf" ==> "application/x-font-truetype"
232 , ".txt" ==> "text/plain"
233 , ".wav" ==> "audio/x-wav"
234 , ".wax" ==> "audio/x-ms-wax"
235 , ".wma" ==> "audio/x-ms-wma"
236 , ".wmv" ==> "video/x-ms-wmv"
237 , ".xbm" ==> "image/x-xbitmap"
238 , ".xml" ==> "text/xml"
239 , ".xpm" ==> "image/x-xpixmap"
240 , ".xwd" ==> "image/x-xwindowdump"
241 , ".zip" ==> "application/zip"
242 ]