diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..838458f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/dist/ \ No newline at end of file diff --git a/Geordi.hs b/Geordi.hs new file mode 100644 index 0000000..00a446e --- /dev/null +++ b/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 + diff --git a/Geordi/UrlPath.hs b/Geordi/UrlPath.hs new file mode 100644 index 0000000..ca51479 --- /dev/null +++ b/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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4b99b36 --- /dev/null +++ b/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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/geordi.cabal b/geordi.cabal new file mode 100644 index 0000000..92feeb4 --- /dev/null +++ b/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.*