@@ -0,0 +1,257 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module Network.Wai.Handler.DevelServer (run) where
6+import Language.Haskell.Interpreter
8+import qualified System.IO
10+import Data.ByteString (ByteString)
11+import Data.ByteString.Lazy.Internal (defaultChunkSize)
12+import qualified Data.ByteString.Char8 as B
13+import qualified Data.ByteString.Lazy as L
14+import qualified Data.ByteString.Lazy.Char8 as L8
16+ ( listenOn, accept, sClose, PortID(PortNumber), Socket
18+import Control.Exception (bracket, finally, Exception, throwIO)
19+import System.IO (Handle, hClose)
20+import Control.Concurrent (forkIO, threadDelay)
21+import Control.Monad (unless, forM)
22+import Data.Maybe (isJust, fromJust, fromMaybe)
24+import Data.Typeable (Typeable)
26+import Network.Socket.SendFile
27+import Control.Arrow (first)
28+import Control.Concurrent.MVar as M
29+import System.Directory (getModificationTime)
31+type FunctionName = String
33+run :: Port -> ModuleName -> FunctionName -> IO ()
34+run port modu func = do
35+ app <- M.newMVar $ loadingApp Nothing
36+ _ <- forkIO $ fillApp modu func app
39+fillApp :: String -> String -> MVar Handler -> IO ()
40+fillApp modu func mapp =
43+ go prevError prevFiles = do
48+ times <- mapM (getModificationTime . fst) prevFiles
49+ return $ times /= map snd prevFiles
50+ (newError, newFiles) <-
52+ then reload prevError
53+ else return (prevError, prevFiles)
56+ reload prevError = do
57+ putStrLn "Attempting to interpret your app..."
58+ _ <- swapMVar mapp $ loadingApp prevError
59+ res <- theapp modu func
62+ putStrLn $ "Compile failed: " ++ show err
63+ _ <- swapMVar mapp $ loadingApp $ Just err
64+ return (Just err, [])
65+ Right (app, files) -> do
66+ putStrLn "Interpreting success, new app loaded"
67+ _ <- swapMVar mapp app
68+ files' <- forM files $ \f -> do
69+ t <- getModificationTime f
71+ return (Nothing, files')
74+loadingApp :: Maybe InterpreterError -> Handler
76+ f $ const $ return $ Response status200
77+ [ ("Content-Type", "text/plain")
79+ ] $ ResponseLBS $ L8.pack $ toMessage err
81+ toMessage Nothing = "Loading code changes, please wait"
82+ toMessage (Just err') = "Error loading code: " ++ show err'
84+type Handler = (Application -> IO ()) -> IO ()
85+type MHandler = M.MVar Handler
87+theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))
91+ mods <- getLoadedModules
92+ setImports ["Prelude", "Network.Wai", modu]
93+ app <- interpret func infer
94+ return (app, map toFile mods)
96+ toFile s = map toSlash s ++ ".hs"
100+run' :: Port -> MHandler -> IO ()
101+run' port = withSocketsDo .
103+ (listenOn $ PortNumber $ fromIntegral port)
105+ serveConnections port
108+serveConnections :: Port -> MHandler -> Socket -> IO ()
109+serveConnections port app socket = do
110+ (conn, remoteHost', _) <- accept socket
111+ _ <- forkIO $ serveConnection port app conn remoteHost'
112+ serveConnections port app socket
114+serveConnection :: Port -> MHandler -> Handle -> String -> IO ()
115+serveConnection port handler conn remoteHost' =
120+ serveConnection' = do
121+ env <- hParseRequest port conn remoteHost'
122+ handler' <- M.readMVar handler
123+ handler' $ \app -> do
125+ sendResponse (httpVersion env) conn res
127+hParseRequest :: Port -> Handle -> String -> IO Request
128+hParseRequest port conn remoteHost' = do
129+ headers' <- takeUntilBlank conn id
130+ parseRequest port headers' conn remoteHost'
132+takeUntilBlank :: Handle
133+ -> ([ByteString] -> [ByteString])
135+takeUntilBlank h front = do
136+ l <- stripCR `fmap` B.hGetLine h
138+ then return $ front []
139+ else takeUntilBlank h $ front . (:) l
141+stripCR :: ByteString -> ByteString
144+ | B.last bs == '\r' = B.init bs
147+data InvalidRequest =
148+ NotEnoughLines [String]
150+ | BadFirstLine String
152+ deriving (Show, Typeable)
153+instance Exception InvalidRequest
155+-- | Parse a set of header lines and body into a 'Request'.
161+parseRequest port lines' handle remoteHost' = do
163+ (_:_:_) -> return ()
164+ _ -> throwIO $ NotEnoughLines $ map B.unpack lines'
165+ (method, rpath', gets, httpversion) <- parseFirst $ head lines'
166+ let rpath = '/' : case B.unpack rpath' of
168+ _ -> B.unpack rpath'
169+ let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'
170+ let host' = lookup "Host" heads
171+ unless (isJust host') $ throwIO HostNotIncluded
172+ let host = fromJust host'
173+ let len = fromMaybe 0 $ do
174+ bs <- lookup "Content-Length" heads
175+ let str = B.unpack bs
179+ let (serverName', _) = B.break (== ':') host
181+ { requestMethod = method
182+ , httpVersion = httpversion
183+ , pathInfo = B.pack rpath
184+ , queryString = gets
185+ , serverName = serverName'
187+ , requestHeaders = heads
189+ , requestBody = requestBodyHandle handle len
190+ , errorHandler = System.IO.hPutStr System.IO.stderr
191+ , remoteHost = B.pack remoteHost'
194+parseFirst :: ByteString
195+ -> IO (ByteString, ByteString, ByteString, HttpVersion)
197+ let pieces = B.words s
198+ (method, query, http') <-
200+ [x, y, z] -> return (x, y, z)
201+ _ -> throwIO $ BadFirstLine $ B.unpack s
202+ let (hfirst, hsecond) = B.splitAt 5 http'
203+ unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp
204+ let (rpath, qstring) = B.break (== '?') query
205+ return (method, rpath, qstring, hsecond)
207+sendResponse :: HttpVersion -> Handle -> Response -> IO ()
208+sendResponse httpversion h res = do
209+ B.hPut h $ B.pack "HTTP/"
210+ B.hPut h $ httpversion
211+ B.hPut h $ B.pack " "
212+ B.hPut h $ B.pack $ show $ statusCode $ status res
213+ B.hPut h $ B.pack " "
214+ B.hPut h $ statusMessage $ status res
215+ B.hPut h $ B.pack "\r\n"
216+ mapM_ putHeader $ responseHeaders res
217+ B.hPut h $ B.pack "\r\n"
218+ case responseBody res of
219+ ResponseFile fp -> unsafeSendFile h fp
220+ ResponseEnumerator (Enumerator enum) -> enum myPut h >> return ()
221+ ResponseLBS lbs -> L.hPut h lbs
226+ putHeader (x, y) = do
227+ B.hPut h $ ciOriginal x
228+ B.hPut h $ B.pack ": "
230+ B.hPut h $ B.pack "\r\n"
232+parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)
233+parseHeaderNoAttr s =
234+ let (k, rest) = B.span (/= ':') s
235+ rest' = if not (B.null rest) &&
236+ B.head rest == ':' &&
237+ not (B.null $ B.tail rest) &&
238+ B.head (B.tail rest) == ' '
243+requestBodyHandle :: Handle -> Int -> Source
244+requestBodyHandle h =
247+ go i = Just `fmap` B.hGet h (min i defaultChunkSize)
249+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source
250+requestBodyFunc _ 0 = Source $ return Nothing
251+requestBodyFunc h len = Source $ do
254+ Nothing -> return Nothing
256+ let newLen = len - B.length bs
257+ return $ Just (bs, requestBodyFunc h $ max 0 newLen)