Permalink
Browse files

Added MonadSnap class and instances for common transformers.

  • Loading branch information...
1 parent 5e5750e commit d13de1fb89133b8a856f1ec1b3effb2c42055673 @duairc committed Jun 27, 2010
@@ -8,7 +8,7 @@ import Snap.Util.FileServe
import Server
main :: IO ()
-main = quickServer $
+main = quickServer id $
ifTop (writeBS "hello world") <|>
route [ ("foo", writeBS "bar")
, ("echo/:echoparam", echoHandler)
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
module Server
( ServerConfig(..)
, emptyServerConfig
@@ -30,7 +31,7 @@ data ServerConfig = ServerConfig
, accessLog :: Maybe FilePath
, errorLog :: Maybe FilePath
, compression :: Bool
- , error500Handler :: SomeException -> Snap ()
+ , error500Handler :: MonadSnap m => SomeException -> m ()
}
@@ -68,8 +69,8 @@ commandLineConfig = do
Nothing -> conf
Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}
-server :: ServerConfig -> Snap () -> IO ()
-server config handler = do
+server :: MonadSnap m => ServerConfig -> (m () -> Snap ()) -> m () -> IO ()
+server config f handler = do
putStrLn $ "Listening on " ++ (B.unpack $ interface config)
++ ":" ++ show (port config)
setUTF8Locale (locale config)
@@ -79,7 +80,7 @@ server config handler = do
(hostname config)
(accessLog config)
(errorLog config)
- (catch500 $ compress $ handler)
+ (f $ catch500 $ compress $ handler)
:: IO (Either SomeException ())
threadDelay 1000000
putStrLn "Shutting down"
@@ -88,8 +89,8 @@ server config handler = do
compress = if compression config then withCompression else id
-quickServer :: Snap () -> IO ()
-quickServer = (commandLineConfig >>=) . flip server
+quickServer :: MonadSnap m => (m () -> Snap ()) -> m () -> IO ()
+quickServer f a = commandLineConfig >>= (\c -> server c f a)
setUTF8Locale :: String -> IO ()
@@ -21,7 +21,7 @@ Executable projname
bytestring >= 0.9.1 && <0.10,
snap-core >= 0.2 && <0.3,
snap-server >= 0.2 && <0.3,
- heist >= 0.2.2 && <0.3,
+ heist >= 0.2.3 && <0.3,
hexpat == 0.16,
xhtml-combinators,
unix,
@@ -17,29 +17,30 @@ import Text.Templating.Heist
import Text.Templating.Heist.TemplateDirectory
-templateHandler :: TemplateDirectory Snap
- -> (TemplateDirectory Snap -> Snap ())
- -> (TemplateState Snap -> Snap ())
- -> Snap ()
+templateHandler :: MonadSnap m
+ => TemplateDirectory m
+ -> (TemplateDirectory m -> m ())
+ -> (TemplateState m -> m ())
+ -> m ()
templateHandler td reload f = reload td <|> (f =<< getDirectoryTS td)
-defaultReloadHandler :: TemplateDirectory Snap -> Snap ()
+defaultReloadHandler :: MonadSnap m => TemplateDirectory m -> m ()
defaultReloadHandler td = path "admin/reload" $ do
e <- reloadTemplateDirectory td
modifyResponse $ setContentType "text/plain; charset=utf-8"
writeBS . B.pack $ either id (const "Templates loaded successfully.") e
-render :: TemplateState Snap -> ByteString -> Snap ()
+render :: MonadSnap m => TemplateState m -> ByteString -> m ()
render ts template = do
bytes <- renderTemplate ts template
flip (maybe pass) bytes $ \x -> do
modifyResponse $ setContentType "text/html; charset=utf-8"
writeBS x
-templateServe :: TemplateState Snap -> Snap ()
+templateServe :: MonadSnap m => TemplateState m -> m ()
templateServe ts = ifTop (render ts "index") <|> do
path' <- getSafePath
when (head path' == '_') pass
@@ -14,7 +14,7 @@ import Server
main :: IO ()
main = do
td <- newTemplateDirectory' "templates" emptyTemplateState
- quickServer $ templateHandler td defaultReloadHandler $ \ts ->
+ quickServer id $ templateHandler td defaultReloadHandler $ \ts ->
ifTop (writeBS "hello world") <|>
route [ ("foo", writeBS "bar")
, ("echo/:echoparam", echoHandler)
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
module Server
( ServerConfig(..)
, emptyServerConfig
@@ -30,7 +31,7 @@ data ServerConfig = ServerConfig
, accessLog :: Maybe FilePath
, errorLog :: Maybe FilePath
, compression :: Bool
- , error500Handler :: SomeException -> Snap ()
+ , error500Handler :: MonadSnap m => SomeException -> m ()
}
@@ -68,8 +69,8 @@ commandLineConfig = do
Nothing -> conf
Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}
-server :: ServerConfig -> Snap () -> IO ()
-server config handler = do
+server :: MonadSnap m => ServerConfig -> (m () -> Snap ()) -> m () -> IO ()
+server config f handler = do
putStrLn $ "Listening on " ++ (B.unpack $ interface config)
++ ":" ++ show (port config)
setUTF8Locale (locale config)
@@ -79,7 +80,7 @@ server config handler = do
(hostname config)
(accessLog config)
(errorLog config)
- (catch500 $ compress $ handler)
+ (f $ catch500 $ compress $ handler)
:: IO (Either SomeException ())
threadDelay 1000000
putStrLn "Shutting down"
@@ -88,8 +89,8 @@ server config handler = do
compress = if compression config then withCompression else id
-quickServer :: Snap () -> IO ()
-quickServer = (commandLineConfig >>=) . flip server
+quickServer :: MonadSnap m => (m () -> Snap ()) -> m () -> IO ()
+quickServer f a = commandLineConfig >>= (\c -> server c f a)
setUTF8Locale :: String -> IO ()
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
module Snap.Internal.Routing where
@@ -34,14 +36,14 @@ triggering its fallback. It's NoRoute, so we go to the nearest parent
fallback and try that, which is the baz action.
-}
-data Route a = Action (Snap a) -- wraps a 'Snap' action
- | Capture ByteString (Route a) (Route a) -- captures the dir in a param
- | Dir (Map.Map ByteString (Route a)) (Route a) -- match on a dir
- | NoRoute
+data Route a m = Action ((MonadSnap m) => m a) -- wraps a 'Snap' action
+ | Capture ByteString (Route a m) (Route a m) -- captures the dir in a param
+ | Dir (Map.Map ByteString (Route a m)) (Route a m) -- match on a dir
+ | NoRoute
------------------------------------------------------------------------------
-instance Monoid (Route a) where
+instance Monoid (Route a m) where
mempty = NoRoute
mappend NoRoute r = r
@@ -81,14 +83,14 @@ instance Monoid (Route a) where
------------------------------------------------------------------------------
-routeHeight :: Route a -> Int
+routeHeight :: Route a m -> Int
routeHeight r = case r of
NoRoute -> 1
(Action _) -> 1
(Capture _ r' _) -> 1+routeHeight r'
(Dir rm _) -> 1+foldl max 1 (map routeHeight $ Map.elems rm)
-routeEarliestNC :: Route a -> Int -> Int
+routeEarliestNC :: Route a m -> Int -> Int
routeEarliestNC r n = case r of
NoRoute -> n
(Action _) -> n
@@ -145,7 +147,7 @@ routeEarliestNC r n = case r of
-- > , ("article/:id", renderArticle)
-- > , ("login", method POST doLogin) ]
--
-route :: [(ByteString, Snap a)] -> Snap a
+route :: MonadSnap m => [(ByteString, m a)] -> m a
route rts = do
p <- getRequest >>= return . rqPathInfo
route' (return ()) ([], splitPath p) Map.empty rts'
@@ -158,7 +160,7 @@ route rts = do
-- the request's context path. This is useful if you want to route to a
-- particular handler but you want that handler to receive the 'rqPathInfo' as
-- it is.
-routeLocal :: [(ByteString, Snap a)] -> Snap a
+routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a
routeLocal rts = do
req <- getRequest
let ctx = rqContextPath req
@@ -176,7 +178,7 @@ splitPath = B.splitWith (== (c2w '/'))
------------------------------------------------------------------------------
-pRoute :: (ByteString, Snap a) -> Route a
+pRoute :: MonadSnap m => (ByteString, m a) -> Route a m
pRoute (r, a) = foldr f (Action a) hier
where
hier = filter (not . B.null) $ B.splitWith (== (c2w '/')) r
@@ -186,11 +188,12 @@ pRoute (r, a) = foldr f (Action a) hier
------------------------------------------------------------------------------
-route' :: Snap ()
+route' :: MonadSnap m
+ => m ()
-> ([ByteString], [ByteString])
-> Params
- -> Route a
- -> Snap a
+ -> Route a m
+ -> m a
route' pre (ctx, _) params (Action action) =
localRequest (updateContextPath (B.length ctx') . updateParams)
(pre >> action)
Oops, something went wrong.

0 comments on commit d13de1f

Please sign in to comment.