git.iko.soy/elk
on 2edbe13 help sign in
elk/terminal/src/Develop.hs
256 lines 6.8 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 BackgroundWriter as BW
24import qualified Build
25import qualified Elm.Details as Details
26import qualified Develop.Generate.Help as Help
27import qualified Develop.Generate.Index as Index
28import qualified Develop.StaticFiles as StaticFiles
29import qualified Generate.Html as Html
30import qualified Generate
31import qualified Reporting
32import qualified Reporting.Exit as Exit
33import qualified Reporting.Task as Task
34import qualified Stuff
38-- RUN THE DEV SERVER
41data Flags =
42 Flags
43 { _port :: Maybe Int
44 }
47run :: () -> Flags -> IO ()
48run () (Flags maybePort) =
49 do let port = maybe 8000 id maybePort
50 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 setVerbose False $ setPort port $
61 setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
65-- INDEX
68directoryConfig :: MonadSnap m => DirectoryConfig m
69directoryConfig =
70 fancyDirectoryConfig
71 { indexFiles = []
72 , indexGenerator = \pwd ->
73 do modifyResponse $ setContentType "text/html;charset=utf-8"
74 writeBuilder =<< liftIO (Index.generate pwd)
75 }
79-- NOT FOUND
82error404 :: Snap ()
83error404 =
84 do modifyResponse $ setResponseStatus 404 "Not Found"
85 modifyResponse $ setContentType "text/html;charset=utf-8"
86 writeBuilder $ Help.makePageHtml "NotFound" Nothing
90-- SERVE FILES
93serveFiles :: Snap ()
94serveFiles =
95 do path <- getSafePath
96 guard =<< liftIO (Dir.doesFileExist path)
97 serveElm path <|> serveFilePretty path
101-- SERVE FILES + CODE HIGHLIGHTING
104serveFilePretty :: FilePath -> Snap ()
105serveFilePretty path =
106 let
107 possibleExtensions =
108 getSubExts (takeExtensions path)
109 in
110 case mconcat (map lookupMimeType possibleExtensions) of
111 Nothing ->
112 serveCode path
114 Just mimeType ->
115 serveFileAs mimeType path
118getSubExts :: String -> [String]
119getSubExts fullExtension =
120 if null fullExtension then
121 []
122 else
123 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
126serveCode :: String -> Snap ()
127serveCode path =
128 do code <- liftIO (BS.readFile path)
129 modifyResponse (setContentType "text/html")
130 writeBuilder $
131 Help.makeCodeHtml ('~' : '/' : path) (B.byteString code)
135-- SERVE ELM
138serveElm :: FilePath -> Snap ()
139serveElm path =
140 do guard (takeExtension path == ".elm")
141 modifyResponse (setContentType "text/html")
142 result <- liftIO $ compile path
143 case result of
144 Right builder ->
145 writeBuilder builder
147 Left exit ->
148 writeBuilder $ Help.makePageHtml "Errors" $ Just $
149 Exit.toJson $ Exit.reactorToReport exit
152compile :: FilePath -> IO (Either Exit.Reactor B.Builder)
153compile path =
154 do maybeRoot <- Stuff.findRoot
155 case maybeRoot of
156 Nothing ->
157 return $ Left $ Exit.ReactorNoOutline
159 Just root ->
160 BW.withScope $ \scope -> Stuff.withRootLock root $ Task.run $
161 do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root
162 artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details (NE.List path [])
163 javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts
164 let (NE.List name _) = Build.getRootNames artifacts
165 return $ Html.sandwich name javascript
169-- SERVE STATIC ASSETS
172serveAssets :: Snap ()
173serveAssets =
174 do path <- getSafePath
175 case StaticFiles.lookup path of
176 Nothing ->
177 pass
179 Just (content, mimeType) ->
180 do modifyResponse (setContentType (mimeType <> ";charset=utf-8"))
181 writeBS content
185-- MIME TYPES
188lookupMimeType :: FilePath -> Maybe BS.ByteString
189lookupMimeType ext =
190 HashMap.lookup ext mimeTypeDict
193(==>) :: a -> b -> (a,b)
194(==>) a b =
195 (a, b)
198mimeTypeDict :: HashMap.HashMap FilePath BS.ByteString
199mimeTypeDict =
200 HashMap.fromList
201 [ ".asc" ==> "text/plain"
202 , ".asf" ==> "video/x-ms-asf"
203 , ".asx" ==> "video/x-ms-asf"
204 , ".avi" ==> "video/x-msvideo"
205 , ".bz2" ==> "application/x-bzip"
206 , ".css" ==> "text/css"
207 , ".dtd" ==> "text/xml"
208 , ".dvi" ==> "application/x-dvi"
209 , ".gif" ==> "image/gif"
210 , ".gz" ==> "application/x-gzip"
211 , ".htm" ==> "text/html"
212 , ".html" ==> "text/html"
213 , ".ico" ==> "image/x-icon"
214 , ".jpeg" ==> "image/jpeg"
215 , ".jpg" ==> "image/jpeg"
216 , ".js" ==> "text/javascript"
217 , ".json" ==> "application/json"
218 , ".m3u" ==> "audio/x-mpegurl"
219 , ".mov" ==> "video/quicktime"
220 , ".mp3" ==> "audio/mpeg"
221 , ".mp4" ==> "video/mp4"
222 , ".mpeg" ==> "video/mpeg"
223 , ".mpg" ==> "video/mpeg"
224 , ".ogg" ==> "application/ogg"
225 , ".otf" ==> "font/otf"
226 , ".pac" ==> "application/x-ns-proxy-autoconfig"
227 , ".pdf" ==> "application/pdf"
228 , ".png" ==> "image/png"
229 , ".qt" ==> "video/quicktime"
230 , ".sfnt" ==> "font/sfnt"
231 , ".sig" ==> "application/pgp-signature"
232 , ".spl" ==> "application/futuresplash"
233 , ".svg" ==> "image/svg+xml"
234 , ".swf" ==> "application/x-shockwave-flash"
235 , ".tar" ==> "application/x-tar"
236 , ".tar.bz2" ==> "application/x-bzip-compressed-tar"
237 , ".tar.gz" ==> "application/x-tgz"
238 , ".tbz" ==> "application/x-bzip-compressed-tar"
239 , ".text" ==> "text/plain"
240 , ".tgz" ==> "application/x-tgz"
241 , ".ttf" ==> "font/ttf"
242 , ".txt" ==> "text/plain"
243 , ".wav" ==> "audio/x-wav"
244 , ".wax" ==> "audio/x-ms-wax"
245 , ".webm" ==> "video/webm"
246 , ".webp" ==> "image/webp"
247 , ".wma" ==> "audio/x-ms-wma"
248 , ".wmv" ==> "video/x-ms-wmv"
249 , ".woff" ==> "font/woff"
250 , ".woff2" ==> "font/woff2"
251 , ".xbm" ==> "image/x-xbitmap"
252 , ".xml" ==> "text/xml"
253 , ".xpm" ==> "image/x-xpixmap"
254 , ".xwd" ==> "image/x-xwindowdump"
255 , ".zip" ==> "application/zip"
256 ]