WebPlug.hs

{-# 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/"