public
Created

  • Download Gist
WebPlug.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
import Network.Wai
import Network.Wai.Enumerator
import Network.Wai.Handler.SimpleServer
import Data.Monoid
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List (intercalate)
import Data.List.Split (splitWhen)
import Data.Time
import Control.Applicative.Error
 
newtype RelPath = RelPath { unRelPath :: [String] }
deriving Monoid
 
class IsRelPath a where
toRelPath :: a -> RelPath
fromRelPath :: RelPath -> Maybe a
 
class IsRelPath (Routes a) => WebPlug a where
type Routes a
dispatch :: a -> Routes a -> (Routes a -> AbsPath) -> Application
 
data BlogRoutes = BlogHome | BlogPost String
data Blog = Blog UTCTime -- just a sample of something loaded at init
instance IsRelPath BlogRoutes where
toRelPath BlogHome = RelPath []
toRelPath (BlogPost title) = RelPath [title]
fromRelPath (RelPath []) = Just BlogHome
fromRelPath (RelPath [title]) = Just $ BlogPost title
fromRelPath _ = Nothing
instance WebPlug Blog where
type Routes Blog = BlogRoutes
dispatch _ BlogHome toAbsPath _ =
return $ Response Status200 h $ Right c
where
h = [(ContentType, S.pack "text/plain")]
c = fromLBS $ L.pack $ unAbsPath $ toAbsPath
$ BlogPost "hello-world"
dispatch (Blog now) (BlogPost title) toAbsPath _ =
return $ Response Status200 h $ Right c
where
h = [(ContentType, S.pack "text/plain")]
c = fromLBS $ L.pack $ unlines
[ unAbsPath $ toAbsPath BlogHome
, title
, show now
]
 
data MySiteRoutes = MyHome | MyBlog BlogRoutes
data MySite = MySite Blog
 
instance IsRelPath MySiteRoutes where
toRelPath MyHome = RelPath []
toRelPath (MyBlog b) = RelPath ["blog"] `mappend` toRelPath b
fromRelPath (RelPath []) = Just MyHome
fromRelPath (RelPath ("blog":rest)) =
MyBlog `fmap` fromRelPath (RelPath rest)
fromRelPath _ = Nothing
instance WebPlug MySite where
type Routes MySite = MySiteRoutes
dispatch _ MyHome toAbsPath _ = return $ Response Status200 h $ Right c
where
h = [(ContentType, S.pack "text/plain")]
c = fromLBS $ L.pack $ unAbsPath $ toAbsPath
$ MyBlog $ BlogPost "hello-world"
dispatch (MySite blog) (MyBlog b) toAbsPath req =
dispatch blog b (toAbsPath . MyBlog) req
 
plugToWai :: WebPlug a => a -> String -> Application
plugToWai plug approot req =
handleWai
(\(PathInfo s) ->
case fromRelPath $ parseRelPath s of
Nothing -> Failure ["Path not found"]
Just x -> Success x)
(PathInfo . intercalate "/" . unRelPath . toRelPath)
(\(PathInfo pi) -> AbsPath $ approot ++ pi)
(dispatch plug)
req
 
newtype AbsPath = AbsPath { unAbsPath :: String }
newtype PathInfo = PathInfo { unPathInfo :: String }
handleWai :: (PathInfo -> Failing url)
-> (url -> PathInfo)
-> (PathInfo -> AbsPath)
-> (url -> (url -> AbsPath) -> Application)
-> Application
handleWai parsePI buildPI buildAbsPath dispatch req = do
let pi = PathInfo $ S.unpack $ pathInfo req
case parsePI pi of
Success url -> dispatch url (buildAbsPath . buildPI) req
Failure errors -> return $ Response Status404 [] $ Right $ fromLBS
$ L.pack $ unlines errors
 
parseRelPath :: String -> RelPath
parseRelPath = RelPath . filter (not . null) . splitWhen (== '/')
 
main :: IO ()
main = do
putStrLn "Running..."
now <- getCurrentTime
run 3000 $ plugToWai (MySite $ Blog now) "http://localhost:3000/"

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.