URLT (empty) → 0.10
raw patch · 10 files changed
+338/−0 lines, 10 filesdep +Consumerdep +QuickCheckdep +applicative-extrassetup-changed
Dependencies added: Consumer, QuickCheck, applicative-extras, base, happstack-server, hsp, hsx, mtl, template-haskell
Files
- Setup.hs +2/−0
- URLT.cabal +19/−0
- URLT.hs +16/−0
- URLT/Base.hs +50/−0
- URLT/HandleT.hs +27/−0
- URLT/Happstack.hs +35/−0
- URLT/QuickCheck.hs +10/−0
- URLT/TH.hs +92/−0
- URLT/XMLGenT.hs +86/−0
- debian/copyright +1/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ URLT.cabal view
@@ -0,0 +1,19 @@+Name: URLT+Version: 0.10+License: BSD3+License-File: debian/copyright+Author: jeremy@seereason.com+Maintainer: partners@seereason.com++Synopsis: Library for maintaining correctness of URLs within an application.+Description: A collection of types and functions that ensure that URLs generated by an application are valid. Need more properties here.++Exposed-Modules: URLT, URLT.Base, URLT.HandleT, URLT.Happstack, URLT.QuickCheck, URLT.TH, URLT.XMLGenT+ +Build-Depends: base >= 4 && < 5, mtl, Consumer, template-haskell, happstack-server, QuickCheck, hsx, hsp, applicative-extras++Build-Type: Simple+Category: Web, Language++Extensions: TemplateHaskell,+ FlexibleContexts
+ URLT.hs view
@@ -0,0 +1,16 @@+module URLT + ( module URLT.Base+ , module URLT.XMLGenT+ , module URLT.Happstack+ , module URLT.TH+ , module URLT.QuickCheck+ , module URLT.HandleT+ )+ where++import URLT.XMLGenT+import URLT.Base+import URLT.Happstack+import URLT.TH+import URLT.QuickCheck+import URLT.HandleT
+ URLT/Base.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies #-}+module URLT.Base where++import Control.Applicative+import Control.Monad (MonadPlus)+import Control.Monad.Trans (MonadTrans, MonadIO)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Reader (MonadReader(ask), ReaderT(ReaderT), mapReaderT, withReaderT)+import HSX.XMLGenerator (XMLGenT(..))++-- * URLT Monad Transformer++type Link = String++-- |monad transformer for generating URLs+newtype URLT url m a = URLT { unURLT :: ReaderT (url -> Link) m a }+ deriving (Functor, Monad, MonadFix, MonadPlus, MonadIO, MonadTrans, MonadReader (url -> Link))++-- NOTE: the Monad m requirement comes from the Functor ReaderT instance+instance (Applicative m, Monad m) => Applicative (URLT url m) where+ pure = return+ (URLT (ReaderT f)) <*> (URLT (ReaderT a))+ = URLT $ ReaderT $ \env -> (f env) <*> (a env)++class ShowURL m where+ type URL m+ showURL :: (URL m) -> m Link -- ^ convert a URL value into a Link (aka, a String)++instance (Monad m) => ShowURL (URLT url m) where+ type URL (URLT url m) = url+ showURL url =+ do showF <- ask+ return (showF url)++-- |similar to withReaderT+withURLT :: ((url' -> Link) -> (url -> Link)) -> URLT url m a -> URLT url' m a+withURLT f (URLT r) = URLT $ withReaderT f r++mapURLT :: (m a -> n b) -> URLT url m a -> URLT url n b+mapURLT f (URLT r) = URLT $ mapReaderT f r++-- |used to embed a URLT into a larger parent url+nestURL :: (Monad m) => (url2 -> url1) -> URLT url2 m a -> URLT url1 m a+nestURL b = withURLT (. b)++crossURL :: (Monad m) => (url2 -> url1) -> URLT url1 m (url2 -> Link)+crossURL f = + do showF <- ask+ return $ \url2 -> showF (f url2)+
+ URLT/HandleT.hs view
@@ -0,0 +1,27 @@+module URLT.HandleT where++import Control.Applicative.Error(Failing(Failure, Success))+import Control.Monad.Reader (ReaderT(runReaderT))+import URLT.Base (URLT(unURLT), Link)++data Site link url m a+ = Site { handleLink :: link -> URLT link m a+ , defaultPage :: link+ , formatLink :: link -> url+ , parseLink :: url -> Failing link + }++instance (Monad m) => Functor (Site u l m) where+ fmap f site =+ site { handleLink = \link -> fmap f ((handleLink site) link) }++runSite :: (Monad m) => String -> Site link Link m a -> Link -> m (Failing a)+runSite prefix site linkStr =+ let fLink = + case linkStr of+ "" -> Success (defaultPage site)+ _ -> (parseLink site) linkStr+ in+ case fLink of+ (Failure errs) -> return (Failure errs)+ (Success lnk) -> return . Success =<< runReaderT (unURLT ((handleLink site) lnk)) ((prefix ++) . (formatLink site))
+ URLT/Happstack.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, UndecidableInstances #-}+module URLT.Happstack where++import Control.Applicative.Error (Failing(Failure, Success))+import Control.Monad (MonadPlus(mzero))+import Control.Monad.Trans (lift)+import Data.List (intersperse)+import Happstack.Server (FilterMonad(..), ServerMonad(..), WebMonad(..), ServerPartT, Response, Request(rqPaths), ToMessage(..), dir, runServerPartT, withRequest)+import URLT.Base (URLT(URLT), Link, mapURLT)+import URLT.HandleT (Site, runSite)++instance (ServerMonad m) => ServerMonad (URLT url m) where+ askRq = lift askRq+ localRq f m = mapURLT (localRq f) m++instance (FilterMonad a m)=> FilterMonad a (URLT url m) where+ setFilter = lift . setFilter+ composeFilter = lift . composeFilter+ getFilter = mapURLT getFilter ++instance (WebMonad a m) => WebMonad a (URLT url m) where+ finishWith = lift . finishWith++-- FIXME: the prefix can only be a single directory right now+implSite :: (ToMessage a) => String -> String -> Site link Link (ServerPartT IO) a -> ServerPartT IO Response+implSite domain prefix siteSpec =+ dir (filter (/= '/') prefix) $ + withRequest $ \rq ->+ let link = (concat (intersperse "/" (rqPaths rq)))+ in+ do r <- runServerPartT (runSite (domain ++ prefix) siteSpec link) (rq { rqPaths = [] })+ case r of + (Failure _) -> mzero+ (Success v) -> return (toResponse v)+
+ URLT/QuickCheck.hs view
@@ -0,0 +1,10 @@+module URLT.QuickCheck where++import Control.Applicative.Error (Failing(Success))+import URLT.TH (AsURL(toURLS), fromURL)++asURLInverse_prop :: (Eq url, AsURL url) => url -> Bool+asURLInverse_prop url =+ case (fromURL $ toURLS url "") of+ Success url' -> url == url'+ _ -> False
+ URLT/TH.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}+module URLT.TH where++import Control.Applicative (Applicative((<*>)))+import Control.Applicative.Error (Failing(Failure, Success))+import Control.Monad (replicateM)+import Data.List (intercalate)+import Language.Haskell.TH+import Control.Monad.Consumer (Consumer, next, runConsumer)++class AsURL a where+ toURLS :: a -> ShowS+ fromURLC :: Consumer String (Failing a)++toURL :: (AsURL a) => a -> String+toURL u = '/' : toURLS u ""++fromURL :: (AsURL a) => String -> Failing a+fromURL str =+ fst $ runConsumer (words $ map (\c -> if c == '/' then ' ' else c) str) fromURLC++-- FIXME: handle unexpected end of input+-- FIXME: handle invalid input+-- FIXME: handle when called with a type (not data, newtype)+deriveAsURL :: Name -> Q [Dec]+deriveAsURL name+ = do c <- parseInfo name+ case c of+ Tagged cons cx keys ->+ do let context = [ mkType ''AsURL [varT key] | key <- keys ] ++ map return cx+ i <- instanceD (sequence context) (mkType ''AsURL [mkType name (map varT keys)])+ [ toURLFn cons + , fromURLCFn cons+ ]+ return [i]+ where+ toURLFn :: [(Name, Int)] -> DecQ+ toURLFn cons + = do inp <- newName "inp"+ let body = caseE (varE inp) $+ [ do args <- replicateM nArgs (newName "arg")+ let matchCon = conP conName (map varP args)+ conStr = (nameBase conName) ++ "/"+ match matchCon (normalB (toURLWork conStr args)) []+ | (conName, nArgs) <- cons ]+ toURLWork :: String -> [Name] -> ExpQ+ toURLWork conStr args+ = foldr1 (\ a b -> appE (appE [| (.) |] a) b) ([| ((++) conStr) |] : [ [| toURLS $(varE arg) |] | arg <- args ])+ funD 'toURLS [clause [varP inp] (normalB body) []]+ fromURLCFn :: [(Name,Int)] -> DecQ+ fromURLCFn cons+ = do let body = + do c <- newName "c"+ doE [ bindS (varP c) (varE 'next)+ , noBindS $ caseE (varE c)+ ([ do args <- replicateM nArgs (newName "arg")+ match (conP (mkName "Just") [litP $ stringL (nameBase conName) ])+ (normalB (fromURLWork conName args)) []+ | (conName, nArgs) <- cons+ ] ++ + [ do str <- newName "str"+ let conNames = map (nameBase . fst) cons+ match (conP (mkName "Just") [varP str]) (normalB [| return (Failure ["Got '" ++ $(varE str) ++ "' expecting one of " ++ intercalate ", " conNames ]) |]) []+ , match (conP (mkName "Nothing") []) (normalB [| return (Failure ["Unexpected end of input."]) |]) []+ ])+ + ]+ fromURLWork :: Name -> [Name] -> ExpQ+ fromURLWork conName args+ = doE $ [ bindS (varP arg) [| fromURLC |] | arg <- args ] +++ [ noBindS [| return $(foldl (\a b -> appE (appE [| (<*>) |] a) b) (appE [| Success |] (conE conName)) (map varE args)) |] ]+ funD 'fromURLC [clause [] (normalB body) []]+++mkType :: Name -> [TypeQ] -> TypeQ+mkType con = foldl appT (conT con)++data Class = Tagged [(Name, Int)] Cxt [Name]+++parseInfo :: Name -> Q Class+parseInfo name+ = do info <- reify name+ case info of+ TyConI (DataD cx _ keys cs _) -> return $ Tagged (map conInfo cs) cx keys+ TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx keys+ _ -> error "Invalid input"+ where conInfo (NormalC n args) = (n, length args)+ conInfo (RecC n args) = (n, length args)+ conInfo (InfixC _ n _) = (n, 2)+ conInfo (ForallC _ _ con) = conInfo con+
+ URLT/XMLGenT.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module URLT.XMLGenT where++import HSP+import Control.Applicative ((<$>))+import qualified HSX.XMLGenerator as HSX+import URLT.Base (URLT, ShowURL(showURL), URL)++instance (Monad m) => HSX.XMLGen (URLT url m) where+ type HSX.XML (URLT url m) = XML+ newtype HSX.Child (URLT url m) = UChild { unUChild :: XML }+ newtype HSX.Attribute (URLT url m) = UAttr { unUAttr :: Attribute }++ genElement n attrs children = + do attribs <- map unUAttr <$> asAttr attrs+ childer <- flattenCDATA . map unUChild <$> asChild children+ HSX.XMLGenT $ return (Element+ (toName n)+ attribs+ childer+ )+ xmlToChild = UChild++flattenCDATA :: [XML] -> [XML]+flattenCDATA cxml = + case flP cxml [] of+ [] -> []+ [CDATA _ ""] -> []+ xs -> xs + where+ flP :: [XML] -> [XML] -> [XML]+ flP [] bs = reverse bs+ flP [x] bs = reverse (x:bs)+ flP (x:y:xs) bs = case (x,y) of+ (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs+ _ -> flP (y:xs) (x:bs)++instance (Monad m) => HSX.EmbedAsAttr (URLT url m) Attribute where+ asAttr = return . (:[]) . UAttr ++instance (Monad m) => HSX.EmbedAsAttr (URLT url m) (Attr String Char) where+ asAttr (n := c) = asAttr (n := [c])++instance (Monad m) => HSX.EmbedAsAttr (URLT url m) (Attr String String) where+ asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)++instance (Monad m) => HSX.EmbedAsAttr (URLT url m) (Attr String Bool) where+ asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")+ asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")++instance (Monad m) => HSX.EmbedAsAttr (URLT url m) (Attr String Int) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (Monad m) => EmbedAsChild (URLT url m) Char where+ asChild = XMLGenT . return . (:[]) . UChild . pcdata . (:[])++instance (Monad m) => EmbedAsChild (URLT url m) String where+ asChild = XMLGenT . return . (:[]) . UChild . pcdata++instance (Monad m) => EmbedAsChild (URLT url m) XML where+ asChild = XMLGenT . return . (:[]) . UChild++instance Monad m => EmbedAsChild (URLT url m) () where+ asChild () = return []++instance (Monad m) => AppendChild (URLT url m) XML where+ appAll xml children = do+ chs <- children+ case xml of+ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n as (cs ++ (map unUChild chs))++instance (Monad m) => SetAttr (URLT url m) XML where+ setAll xml hats = do+ attrs <- hats+ case xml of+ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n (foldr (:) as (map unUAttr attrs)) cs++instance (Monad m) => XMLGenerator (URLT url m)+++instance (ShowURL m) => ShowURL (XMLGenT m) where+ type URL (XMLGenT m) = URL m+ showURL url = XMLGenT $ showURL url
+ debian/copyright view
@@ -0,0 +1,1 @@+BSD