Initial Commit

.gitignore

@@ -0,0 +1 @@
+/dist/

Geordi.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE GADTs, KindSignatures, TypeFamilies, TypeOperators, DataKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, RankNTypes, OverloadedStrings #-}
+module Geordi where
+
+import Geordi.UrlPath
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad.Reader 
+import Control.Monad.Writer 
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Text as T
+
+import Data.Conduit
+import Network.HTTP.Types.Status
+import Network.HTTP.Types.URI
+import Network.Wai
+
+data GenUrlPath (x :: [SegmentType *]) where 
+  Generalise :: (forall m. UrlPath m x) -> GenUrlPath x
+
+newtype HandlerTable p s x = HT { unHT :: ReaderT (GenUrlPath p, GenUrlPath s) 
+                                        ( WriterT [ExistsSegs Handler] IO) x  
+                                } 
+  deriving ( Functor
+           , Monad
+           , Applicative
+           , MonadIO
+           , MonadWriter [ExistsSegs Handler]
+           , MonadReader (GenUrlPath p, GenUrlPath s)
+           , MonadFix
+           )
+
+type HandlerM x = ResourceT IO x
+
+type family   HandlerFor (ts :: [SegmentType *])
+type instance HandlerFor ('[])                 = HandlerM Response
+type instance HandlerFor (StringSeg ': xs)     = HandlerFor xs
+type instance HandlerFor (UrlParam x ': xs)    = x -> HandlerFor xs
+type instance HandlerFor (QueryParam x ': xs)  = x -> HandlerFor xs
+type instance HandlerFor (PostParam x ': xs)   = x -> HandlerFor xs
+type instance HandlerFor (CookieParam x ': xs) = x -> HandlerFor xs
+
+data ExistsSegs :: ([SegmentType *] -> *) -> * where
+  ExI :: a b -> ExistsSegs a
+
+data Handler :: [SegmentType *] -> * where
+  Handle :: UrlPath m ts -> HandlerFor ts -> Handler ts
+
+runHandler :: (T.Text -> Maybe T.Text) 
+           -> [T.Text] 
+           -> UrlPath m ts 
+           -> HandlerFor ts 
+           -> Maybe (HandlerM Response)
+runHandler t (x:xs) (Str x'     :/ ps) h = if x == x' then runHandler t xs ps h
+                                                      else Nothing
+runHandler t (x:xs) (Param      :/ ps) h = parse x 
+                                           >>= runHandler t xs ps . h 
+runHandler t xs     (Query x    :/ ps) h = t x >>= parse
+                                           >>= runHandler t xs ps . h 
+runHandler t xs     (QueryOpt x :/ ps) h = maybe (Just Nothing) (fmap Just . parse) (t x) 
+                                           >>= runHandler t xs ps . h 
+runHandler t []     (Empty           ) h = Just h 
+runHandler _ _      _                  _ = Nothing
+
+go :: [ExistsSegs Handler] -> Application
+go [] _ = do liftIO $ putStrLn "404 not found"; return $ responseLBS status404 [] "404 not found"
+go (ExI (Handle a b):hs) req 
+  = let queries = flip lookup $ map (second $ fromMaybe "") $ queryToQueryText $ queryString req
+     in case runHandler queries (pathInfo req) a b of 
+          Just v -> v
+          Nothing -> go hs req
+
+add :: Handler u -> HandlerTable p s ()
+add x = tell [ExI x]
+
+interpret :: GenUrlPath x -> UrlPath m x
+interpret (Generalise x) = x
+
+handle :: MethodSingleton m 
+       -> UrlPath m ts 
+       -> HandlerFor ((prefix :++: ts) :++: suffix) 
+       -> HandlerTable prefix suffix (Handler ((prefix :++: ts) :++: suffix))
+handle method path action
+  = do (px, sx) <- (interpret *** interpret) 
+               <$> (ask :: HandlerTable prefix suffix (GenUrlPath prefix, GenUrlPath suffix))
+       let x = Handle ((px // path) // sx) action 
+       add x
+       return x
+
+get  = handle MethodGet
+post = handle MethodPost
+
+link :: Handler ts -> LinkTo ts
+link (Handle u _) = linkUrl u
+
+notActuallyAWebFramework :: HandlerTable '[] '[] () -> IO (Application)
+notActuallyAWebFramework = fmap go 
+                         . fmap snd 
+                         . runWriterT 
+                         . flip runReaderT (Generalise Empty , Generalise Empty) 
+                         . unHT
+
+prefix :: (forall m. UrlPath m n) -> HandlerTable (p :++: n) s x -> HandlerTable p s x
+prefix p (HT x) = do (Generalise v, s) <- ask
+                     (r, w) <- liftIO $ runWriterT $ flip runReaderT (Generalise (v // p), s) x
+                     tell w
+                     return r
+
+suffix :: (forall m. UrlPath m n) -> HandlerTable p (s :++: n) x -> HandlerTable p s x
+suffix p (HT x) = do (px, Generalise v) <- ask
+                     (r, w) <- liftIO $ runWriterT $ flip runReaderT (px, Generalise (v // p)) x
+                     tell w
+                     return r
+

Geordi/UrlPath.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE GADTs, KindSignatures, DataKinds, TypeOperators, TypeFamilies, OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Geordi.UrlPath where
+
+import Control.Applicative
+import Data.Function
+import Data.List
+import Data.Maybe
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import qualified Data.Text as T
+import qualified Data.ByteString as B
+
+readMay :: Read a => String -> Maybe a
+readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+               [x] -> Just x
+               _ -> Nothing
+
+data Method = GET | POST
+
+data MethodSingleton :: Method -> * where
+  MethodGet  :: MethodSingleton GET
+  MethodPost :: MethodSingleton POST
+
+data SegmentType x = UrlParam x | QueryParam x | CookieParam x | StringSeg | PostParam x
+
+class Param a where 
+  render :: a -> T.Text
+  parse  :: T.Text -> Maybe a
+
+instance Param Int where
+  render = T.pack . show
+  parse  = readMay . T.unpack 
+
+instance Param Bool where
+  render = T.pack . show
+  parse  = readMay . T.unpack 
+
+instance Param [Char] where
+  render = T.pack
+  parse  = Just . T.unpack
+
+type family (:++:) (a :: [SegmentType *])  (b :: [SegmentType *]) :: [SegmentType *]
+type instance (:++:) '[] x = x
+type instance (:++:) (x ': xs) y = x ': (xs :++: y)
+
+data UrlSegment :: Method -> SegmentType * -> * where
+   Param    :: (Param a) => UrlSegment m (UrlParam a)
+   Query    :: (Param a) => T.Text -> UrlSegment m (QueryParam a)
+   QueryOpt :: (Param a) => T.Text -> UrlSegment m (QueryParam (Maybe a))
+   Posted   :: (Param a) => T.Text -> UrlSegment POST (PostParam a)
+   Cookie   :: (Param a) => T.Text -> UrlSegment m (CookieParam a)
+   Str      :: T.Text -> UrlSegment m (StringSeg)
+
+infixr 7 :/
+-- Indexed by the type of a handler for that particular URLPath
+data UrlPath :: Method -> [SegmentType *] -> * where
+  Empty :: UrlPath m '[] 
+  (:/) :: UrlSegment m t -> UrlPath m ts -> UrlPath m (t ': ts)
+
+str           :: T.Text -> UrlPath m '[StringSeg]
+str            = (:/ Empty) . Str
+query         :: Param p => T.Text ->  UrlPath m '[QueryParam p]
+query          = (:/ Empty) . Query
+posted        :: Param p => T.Text ->  UrlPath POST '[PostParam p]
+posted         = (:/ Empty) . Posted
+cookie        :: Param p => T.Text ->  UrlPath m '[CookieParam p]
+cookie         = (:/ Empty) . Cookie
+param         :: Param p => UrlPath m '[UrlParam p]
+param          = (Param :/ Empty) 
+optionalQuery :: Param p => T.Text ->  UrlPath m '[QueryParam (Maybe p)]
+optionalQuery  = (:/ Empty) . QueryOpt
+
+(//) :: UrlPath m a -> UrlPath m b -> UrlPath m (a :++: b)
+Empty     // y = y
+(x :/ xs) // y = x :/ (xs // y)
+
+type family   LinkTo (x :: [SegmentType *])
+type instance LinkTo '[]                   = T.Text
+type instance LinkTo (UrlParam x ': xs)    = x -> LinkTo xs
+type instance LinkTo (QueryParam x ': xs)  = x -> LinkTo xs
+type instance LinkTo (PostParam x ': xs)   = LinkTo xs
+type instance LinkTo (StringSeg ': xs)     = LinkTo xs
+type instance LinkTo (CookieParam x ': xs) = LinkTo xs
+
+linkUrl :: UrlPath x ts -> LinkTo ts
+linkUrl = link' "" ""
+  where 
+    (.+) = T.append
+    link' :: T.Text -> T.Text -> UrlPath x ts -> LinkTo ts
+    link' acc qs Empty             = acc .+ (if qs == "" then "" else T.cons '?' $ T.tail qs)
+    link' acc qs (Str str :/ p)    = link' (acc .+ "/" .+ str) qs p
+    link' acc qs (Cookie str :/ p) = link' acc qs  p
+    link' acc qs (Param :/ p)      = \v -> link' (acc .+ "/" .+ render v) qs p
+    link' acc qs (Query x :/ p)    = \v -> link' acc (qs .+ "&" .+ x .+ "=" .+ render v) p
+    link' acc qs (QueryOpt x :/ p) = maybe (link' acc qs p) 
+                                           (\v -> link' acc (qs .+ "&" .+ x .+ "=" .+ render v) p) 
+
+splitOn c = filter (/= [c]) . groupBy (\x y -> (x == c) == (y == c) ) 
+
+-- Quasiquoter parser
+expQuoter :: String -> Q Exp
+expQuoter x 
+  =  do x1 <- quoter pieceQuoter . splitOn '/' . takeWhile (/= '?')          . filter notSpace $ x
+        x2 <- quoter queryQuoter . splitOn '&' . drop 1 . dropWhile (/= '?') . filter notSpace $ x
+        Just slashslash <- qLookupName False "//"
+        return $ AppE (AppE (VarE slashslash) x1) x2
+  where notSpace x = x /= ' ' && x /= '\n' && x /= '\r' && x /= '\t'
+        quoter subquoter ls 
+          = do Just end        <- qLookupName False "Empty"  
+               Just slashslash <- qLookupName False ":/"
+               ls' <- mapM subquoter ls
+               return $ foldr (\x y -> AppE (AppE (ConE slashslash) x) y) (ConE end) ls'
+
+        queryCon    = ConE . fromJust <$> qLookupName False "Query"
+        strCon      = ConE . fromJust <$> qLookupName False "Str"
+        queryOptCon = ConE . fromJust <$> qLookupName False "QueryOpt" 
+        paramCon    = ConE . fromJust <$> qLookupName False "Param"
+
+        pieceQuoter (':':_) = paramCon
+        pieceQuoter n       = flip AppE <$> litE (stringL n) <*> strCon
+        queryQuoter ('.':n) = flip AppE <$> litE (stringL n) <*> queryOptCon
+        queryQuoter n       = flip AppE <$> litE (stringL n) <*> queryCon
+
+-- Quasiquoter for UrlPath. Better to write [r| /hello/:p1/:p2/ ] 
+-- than: "Hello" :/ Param :/ Param :/ Empty, but only a little.
+r :: QuasiQuoter
+r = QuasiQuoter expQuoter undefined undefined undefined 

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2012, Liam O'Connor-Davis
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Liam O'Connor-Davis nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

geordi.cabal

@@ -0,0 +1,27 @@
+-- Initial geordi.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                geordi
+version:             0.1.0.0
+synopsis:            A well-typed, minimalist web-framework for GHC Haskell
+-- description:         
+homepage:            http://github.com/liamoc/geordi
+license:             BSD3
+license-file:        LICENSE
+author:              Liam O'Connor-Davis
+maintainer:          me@liamoc.net
+-- copyright:           
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     Geordi
+  build-depends:       base ==4.6.*
+                     , mtl ==2.1.*
+                     , text ==0.11.*
+                     , conduit ==0.5.*
+                     , http-types ==0.7.*
+                     , wai ==1.3.*
+                     , template-haskell ==2.8.*
+                     , bytestring ==0.10.*