Fake Haskell routing DSL

FakeWebFramework.hs

{-# LANGUAGE GADTs, KindSignatures #-}
module FakeWebFramework (add , notActuallyAWebFramework, get, Handler', link) where

import UrlPath
import Control.Monad.Writer 
import Data.Maybe

maybeRead :: (Read a) => String -> Maybe a
maybeRead s = case reads s of
  [(x, "")] -> Just x
  _         -> Nothing

-- Wrap whatever handler in an existential
data Handler where
  Handle :: UrlPath a s -> a -> Handler

data Handler' :: * -> * where
  Handle' :: UrlPath a s -> a  -> Handler' s


-- Parse arguments and match against a handler (possibly)
match :: [String] -> UrlPath a s -> a -> Maybe (IO ())
match [] End a = Just a
match (x:xs) (Param p) a = maybeRead x >>= match xs p . a
match (x:xs) (str :/ p) a = if x == str then match xs p a else Nothing
match _ _ _ = Nothing

-- Returns the first handler action that works.
go :: [Handler] -> IO ()
go h = forever $ getLine >>= go' h 
  where go' [] _ = putStrLn "404 not found."
        go' (Handle a b : hs) str = fromMaybe (go' hs str) (match (getPieces str) a b) 


-- Our routing DSL
add :: Handler' s -> WriterT [Handler] IO ()
add (Handle' p p') = tell [Handle p p']

get :: UrlPath a s -> a -> Handler' s
get = Handle'

link :: Handler' s -> s
link (Handle' u _) = link' "" u

notActuallyAWebFramework :: WriterT [Handler] IO () -> IO () 
notActuallyAWebFramework = (go =<<) . fmap snd . runWriterT 

Main.hs

{-# LANGUAGE QuasiQuotes, GADTs, ScopedTypeVariables #-}

import FakeWebFramework
import UrlPath
import Data.IORef
import System.IO.Unsafe

-- our "database" :)
counter :: IORef Int
{-# NOINLINE counter #-}
counter = unsafePerformIO (newIORef 0)

showCounter = readIORef counter >>= putStrLn . ("The counter is:" ++) . show 

increment = get [r| /count/increment |] $ do 
              modifyIORef counter (1 +)                      
              putStrLn $ "Go to " ++ link decrement ++  " to undo this"
              showCounter 

decrement = get [r| /count/decrement |] $ do
              modifyIORef counter (\x -> x - 1)
              putStrLn $ "Go to " ++ link increment ++ " to undo this"
              showCounter

setCounter = get [r| /count/set/:x |] $ \ (x :: Int) -> do
               writeIORef counter x
               putStrLn $ "Go to " ++ link setSecret x False ++ " for more information!"
               showCounter

setSecret = get [r| /count/set/:x/:secret |] $ \ (x :: Int) (secret :: Bool) -> do 
              if secret then putStrLn $ "The secret is 42! Now you know, you may as well just use " ++ link setCounter x ++ " from now on."
                        else putStrLn $ "Not telling the secret. Try going to " ++ link setSecret x True ++ " for the secret!"
              writeIORef counter x
              showCounter

main :: IO ()
main = do notActuallyAWebFramework $ do
            add increment
            add decrement
            add setCounter
            add setSecret
                                        

UrlPath.hs

{-# LANGUAGE GADTs, KindSignatures #-}
module UrlPath where

import Language.Haskell.TH.Quote
import Data.List
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Function

-- Indexed by the type of a handler for that particular URLPath
data UrlPath :: * -> * -> * where
  End :: UrlPath (IO ()) String
  (:/) :: String -> UrlPath a s -> UrlPath a s
  Param :: (Read p, Show p) => UrlPath a s -> UrlPath (p -> a) (p -> s)

link' :: String -> UrlPath a s -> s
link' acc End = acc 
link' acc (str :/ p) = link' (acc ++ "/" ++ str) p
link' acc (Param p) = \v -> link' (acc ++ "/" ++ show v) p  

-- Smashes a string into / separated strings
getPieces :: String -> [String]
getPieces = filter (/= "/") . groupBy ((==) `on` (== '/')) 

-- Quasiquoter parser
expQuoter :: String -> Q Exp
expQuoter = expQuoter' . getPieces . filter (/=' ')

expQuoter' :: [String] -> Q Exp
expQuoter' [] = do Just end <- qLookupName False "End" 
                   return $ ConE end
expQuoter' ((':':_):xs) = do Just op <- qLookupName False "Param"
                             v <- expQuoter' xs 
                             return $ AppE (ConE op) v
expQuoter' (x:xs) = do Just op <- qLookupName False ":/"
                       v <- expQuoter' xs 
                       return $ AppE (AppE (ConE op) (LitE $ StringL x)) v

-- Quasiquoter for UrlPath. Better to write [r| /hello/:p1/:p2/ ] than: "Hello" :/ Param (Param End), but only a little.
r :: QuasiQuoter
r = QuasiQuoter expQuoter undefined undefined undefined