Browse files

Initial Commit

  • Loading branch information...
0 parents commit b8500a819a884124108adcc5f4c083c86f6d05c7 @liamoc committed Nov 14, 2012
Showing with 306 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +116 −0 Geordi.hs
  3. +130 −0 Geordi/UrlPath.hs
  4. +30 −0 LICENSE
  5. +2 −0 Setup.hs
  6. +27 −0 geordi.cabal
1 .gitignore
@@ -0,0 +1 @@
+/dist/
116 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
+
130 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
30 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.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
27 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.*

0 comments on commit b8500a8

Please sign in to comment.