diff --git a/src/Web/App/Main.hs b/src/Web/App/Main.hs --- a/src/Web/App/Main.hs +++ b/src/Web/App/Main.hs @@ -117,15 +117,17 @@ start p c k Nothing Nothing exitImmediately ExitSuccess exitImmediately ExitSuccess - start port cert key out err = runServer ((,) <$> cert <*> key) port pre teardown wai - where (wai, teardown) = toApplication runToIO app mws - pre = do + start port cert key out err = do + (wai, teardown) <- toApplication runToIO isTls app mws + runServer ((,) <$> cert <*> key) port pre teardown wai + where pre = do -- drop privileges after binding to a port getRealGroupID >>= setEffectiveGroupID getRealUserID >>= setEffectiveUserID -- redirect I/O maybe (return ()) (redirectHandle stdout) out maybe (return ()) (redirectHandle stderr) err + isTls = isJust cert && isJust key redirectHandle hdl pth = do exists <- fileExist pth when (not exists) $ writeFile pth "" diff --git a/src/Web/App/Path.hs b/src/Web/App/Path.hs --- a/src/Web/App/Path.hs +++ b/src/Web/App/Path.hs @@ -14,7 +14,7 @@ module Web.App.Path ( -- * Types - Path, + Path(..), -- * Path Constructors literal, captured, diff --git a/src/Web/App/RouteT.hs b/src/Web/App/RouteT.hs --- a/src/Web/App/RouteT.hs +++ b/src/Web/App/RouteT.hs @@ -9,7 +9,7 @@ Monad transformer used for defining web app routes. -} -{-# LANGUAGE OverloadedStrings, TupleSections #-} +{-# LANGUAGE OverloadedStrings, TupleSections, BangPatterns #-} module Web.App.RouteT ( @@ -27,10 +27,12 @@ method, matchAll, -- * Monadic actions - halt, + abort, + finish, next, writeBody, request, + isTLS, addHeader, status, headers, @@ -87,7 +89,8 @@ data EvalState = Normal -- ^ continue executing as normal | Next -- ^ skip to the next route - | Halt -- ^ stop evaluation altogether + | Finish -- ^ stop evaluation and return what's been accumulated. + | Abort -- ^ stop evaluation altogether, setting new HTTP response deriving (Eq) data ResponseChange = SetStatus Status @@ -103,36 +106,37 @@ f (s, hdrs, sm) ((AddBytes bs):rs) = f (s, hdrs, sm <> bs) rs -- |Monad transformer in which routes are evaluated. Evaluation may be stopped --- via 'halt', 'next', or 'redirect'. +-- via 'abort', 'finish', 'next', or 'redirect'. newtype RouteT s m a = RouteT { runRouteT :: TVar s -- ^ tvar containing state + -> Bool -- ^ whether or not a certificate was installed -> Path -- ^ path of route -> Request -- ^ request being served -> m (a, (EvalState, [ResponseChange])) } instance (WebAppState s, Functor m) => Functor (RouteT s m) where - fmap f m = RouteT $ \st pth req -> fmap apply $ runRouteT m st pth req + fmap f m = RouteT $ \st sec pth req -> fmap apply $ runRouteT m st sec pth req where apply (a, c) = (f a, c) instance (WebAppState s, Monad m) => Applicative (RouteT s m) where - pure a = RouteT $ \_ _ _ -> return (a, (Normal, mempty)) + pure a = RouteT $ \_ _ _ _ -> return (a, (Normal, mempty)) (<*>) = ap instance (WebAppState s, Monad m) => Monad (RouteT s m) where - fail msg = RouteT $ \_ _ _ -> fail msg + fail msg = RouteT $ \_ _ _ _ -> fail msg m >>= k = RouteT actionf where - actionf st pth req = runRouteT m st pth req >>= handleFirst + actionf st sec pth req = runRouteT m st sec pth req >>= handleFirst where - handleFirst (x, (Normal, cng1)) = runRouteT (k x) st pth req >>= handleSecond + handleFirst (x, (Normal, cng1)) = runRouteT (k x) st sec pth req >>= handleSecond where handleSecond (x', (sts, cng2)) = return (x', (sts, cng3)) - where cng3 = bool (cng1 <> cng2) cng2 $ sts == Halt + where cng3 = bool (cng1 <> cng2) cng2 $ sts == Abort handleFirst (_, c) = return (undefined, c) instance (WebAppState s) => MonadTrans (RouteT s) where - lift m = RouteT $ \_ _ _ -> m >>= return . (,(Normal, mempty)) + lift m = RouteT $ \_ _ _ _ -> m >>= return . (,(Normal, mempty)) instance (WebAppState s, MonadIO m) => MonadIO (RouteT s m) where liftIO = lift . liftIO @@ -142,20 +146,24 @@ -- |INTERNAL A helper to avoid having the RouteT constructor appear everywhere (DRY) {-# INLINE context #-} context :: (WebAppState s, Monad m) => EvalState -> [ResponseChange] -> RouteT s m () -context st hc = RouteT $ \_ _ _ -> return ((), (st, hc)) +context st hc = RouteT $ \_ _ _ _ -> return ((), (st, hc)) -- |INTERNAL Get the state TVar. stateTVar :: (WebAppState s, Monad m) => RouteT s m (TVar s) -stateTVar = RouteT $ \st _ _ -> return (st, (Normal, mempty)) +stateTVar = RouteT $ \st _ _ _ -> return (st, (Normal, mempty)) -- |INTERNAL Get the route's path. This can be different across different evaluations of the same route. path :: (WebAppState s, Monad m) => RouteT s m Path -path = RouteT $ \_ pth _ -> return (pth, (Normal, mempty)) +path = RouteT $ \_ _ pth _ -> return (pth, (Normal, mempty)) -- |Get the 'Request' being served. request :: (WebAppState s, Monad m) => RouteT s m Request -request = RouteT $ \_ _ req -> return (req, (Normal, mempty)) +request = RouteT $ \_ _ _ req -> return (req, (Normal, mempty)) +-- |Whether or not the server is using certificates +isTLS :: (WebAppState s, Monad m) => RouteT s m Bool +isTLS = RouteT $ \_ sec _ _ -> return (sec, (Normal, mempty)) + -- | Get the web app state. getState :: (WebAppState s, MonadIO m) => RouteT s m s getState = liftIO . readTVarIO =<< stateTVar @@ -177,9 +185,13 @@ writeBody w = context Normal [AddBytes (stream' w)] -- |Halt route evaluation and provide a 'Status', '[Header]', and 'Stream'. -halt :: (WebAppState s, Monad m) => Status -> [Header] -> Stream -> RouteT s m a -halt s h b = context Halt [SetStatus s, AddBytes b, AddHeaders h] >> undefined +abort :: (WebAppState s, Monad m) => Status -> [Header] -> Stream -> RouteT s m a +abort s h b = context Abort [SetStatus s, AddBytes b, AddHeaders h] >> undefined +-- |Halt route evaluation and return the accumulated HTTP response. +finish :: (WebAppState s, Monad m) => RouteT s m a +finish = context Finish mempty >> undefined + -- |Halt route evaluation and move onto the next matched route. next :: (WebAppState s, Monad m) => RouteT s m a next = context Next [] >> undefined @@ -188,8 +200,8 @@ -- an HTTP status of 302. Route evaluation halts. {-# INLINE redirect #-} redirect :: (WebAppState s, MonadIO m) => ByteString -> RouteT s m () -redirect url = halt status302 [("Location",url)] mempty - +redirect url = status status302 >> addHeader "Location" url >> finish + -- |Get the 'Request''s headers. headers :: (WebAppState s, Monad m) => RouteT s m [Header] headers = requestHeaders <$> request @@ -200,7 +212,7 @@ -- |Read the 'Request''s parameters (in order captures, HTTP body, URI query). params :: (WebAppState s, MonadIO m) => RouteT s m Query -params = maybe (readAll >>= insertMutVault cachedParamsKey) return =<< lookupMutVault cachedParamsKey +params = readAll -- maybe (readAll >>= insertMutVault cachedParamsKey) return =<< lookupMutVault cachedParamsKey where readAll = mconcat <$> sequence [cap, bdy, queryString <$> request] cap = map toQueryItem <$> (pathCaptures <$> path <*> (pathInfo <$> request)) @@ -253,18 +265,19 @@ -- |Makes an 'Application' from routes and middleware. toApplication :: (WebAppState s, Monad m) => (m (Maybe Response) -> IO (Maybe Response)) -- ^ run your monadic type to IO + -> Bool -- ^ whether or not the server is using TLS -> [Route s m] -- ^ routes -> [Middleware] -- ^ middlewares - -> (Application, IO ()) -- ^ (application, teardown action) -toApplication runToIO routes mws = (app', readTVarIO st >>= destroyState) + -> IO (Application, IO ()) -- ^ (application, teardown action) +toApplication runToIO sec routes mws = do + st <- newTVarIO =<< initState + return (app' st, readTVarIO st >>= destroyState) where - st = unsafePerformIO (newTVarIO =<< initState) - {-# NOINLINE st #-} plainText = [("Content-Type", "text/plain; charset=utf-8")] - app' = foldl (flip ($)) app mws - app req callback = go =<< findSuccessful routeMatches runRoute routes + app' st = foldl (flip ($)) (app st) mws + app st req callback = go =<< findSuccessful routeMatches runRoute routes where - runRoute (Route _ pth act) = runToIO $ toResponse <$> runRouteT act st pth (addMutVault req) + runRoute (Route _ pth act) = runToIO $ toResponse <$> runRouteT act st sec pth (addMutVault req) routeMatches (Route pd pth _) = pd req && pathMatches pth (pathInfo req) toResponse (_, (Next, _)) = Nothing toResponse (_, (_, cng)) = Just $ flattenResponse cng diff --git a/webapp.cabal b/webapp.cabal --- a/webapp.cabal +++ b/webapp.cabal @@ -1,5 +1,5 @@ Name: webapp -Version: 0.5.0 +Version: 0.6.0 Synopsis: Haskell web app framework based on WAI & Warp Homepage: https://github.com/natesymer/webapp Bug-reports: https://github.com/natesymer/webapp/issues