on-a-horse 0.2 → 0.3
raw patch · 8 files changed
+195/−213 lines, 8 filesdep +case-insensitivedep +cookiedep +http-typesdep −hackdep −hack-contribdep −hack-handler-evhttp
Dependencies added: case-insensitive, cookie, http-types, text, transformers, utf8-string, wai, wai-extra, warp
Dependencies removed: hack, hack-contrib, hack-handler-evhttp, hamlet
Files
- Web/Horse.hs +3/−4
- Web/Horse/Forms.hs +2/−2
- Web/Horse/Forms/Basic.hs +28/−39
- Web/Horse/Forms/Types.hs +2/−7
- Web/Horse/Hack.hs +0/−104
- Web/Horse/Server.hs +112/−0
- on-a-horse.cabal +5/−6
- tutorial.lhs +43/−51
Web/Horse.hs view
@@ -1,12 +1,11 @@ module Web.Horse - (module Text.Hamlet, module Web.Horse.Forms.Types, + (module Web.Horse.Forms.Types, module Web.Horse.Forms.Basic, module Web.Horse.Forms, - module Web.Horse.Hack, + module Web.Horse.Server, module Control.Arrow.Transformer.Automaton.Monad) where -import Text.Hamlet import Web.Horse.Forms.Types import Web.Horse.Forms.Basic import Web.Horse.Forms-import Web.Horse.Hack+import Web.Horse.Server import Control.Arrow.Transformer.Automaton.Monad
Web/Horse/Forms.hs view
@@ -5,10 +5,10 @@ import Web.Horse.Forms.Types import Web.Horse.Forms.Basic+import Data.ByteString.Lazy (ByteString) import Data.Monoid import Data.List.Split (splitOn) import Safe (readMay)-import Text.Hamlet import Control.Applicative import Control.Arrow import Control.Monad@@ -39,7 +39,7 @@ :: (ArrowAddAutomaton a1 may a', ArrowAddLabel a may, ArrowReader FormIn may) =>- String -> [(String, b)] -> a () (Html (), Maybe b)+ String -> [(String, b)] -> a () (String, Maybe b) enumForm label vs = withInput $ (proc ((),nm,fi) -> do n_curr <- keepState (-1) -< extractNumber fi
Web/Horse/Forms/Basic.hs view
@@ -2,50 +2,39 @@ module Web.Horse.Forms.Basic where -import Data.ByteString.Lazy (ByteString)-import Data.ByteString.Lazy.Char8 ()-import Text.Hamlet+import Control.Arrow import Data.Monoid -textField :: String -> Maybe String -> String -> String -> Html ()-textField label err val name = ($ undefined) $- [$hamlet| - $maybe err e- %span.error $e$- %br- %label- $label$- %br- %input!type=text!value=$val$!name=$name$- %br|]+textField :: String -> Maybe String -> String -> String -> String+textField label err val name = + mconcat $ [+ maybe "" (\x -> mconcat ["<span class=\"error\">", x, "</span><br/>"]) err,+ "<label>", label, "<br/><input type=\"text\" value=\"", val, "\" name=\"", name, "\"><br/></label>"+ ] -link :: String -> String -> Html ()-link linkName name = ($ undefined) $ [$hamlet|- %a!href="?$name$=1" $linkName$- %br|]+link :: String -> String -> String+link linkName name = mconcat ["<a href=\"?", name, "=1\">", linkName, "</a><br/>"] -select :: String -> [String] -> Int -> String -> Html ()-select label options val name = ($ undefined) $ - [$hamlet|- %label $label$- %br- %select!name=$name$- $forall opts opt- $if isSelected.opt- %option!selected!value=$string.num.opt$ $string.optVal.opt$- $else- %option!value=$string.num.opt$ $string.optVal.opt$- %br |]+select :: String -> [String] -> Int -> String -> String+select label options val name = + mconcat [+ "<label>", label, "<br/>",+ "<select name=\"", name, "\">",+ opts,+ "</select>",+ "<br/>",+ "</label>"+ ] where- opts = (zip3 (map (==val) [0..]) (map show [(0::Int)..]) options)- isSelected (x,_,_) = x- num (_,y,_) = y- optVal (_,_,z) = z+ opts = mconcat $ map renderOpt (zip [0..] options)+ renderOpt (n, opt) = mconcat $ [+ "<option ", if n == val then "selected=\"selected\"" else "",+ " value=\"", show n, "\">",+ opt,+ "</option>"+ ] -wrapForm :: Html () -> Html ()-wrapForm f = mconcat [preEscapedString "<form method='POST' action=''>", f, - preEscapedString "<input type='submit'></input></form>"]--+wrapForm :: String -> String+wrapForm f = mconcat ["<form method='POST' action=''>", f, "<input type='submit'></input></form>"]
Web/Horse/Forms/Types.hs view
@@ -6,14 +6,13 @@ import Control.Arrow.Transformer.Automaton.Monad import Control.Arrow.Transformer.Automaton.Maybe import Control.Arrow.Transformer.LabeledArrow-import Text.Hamlet import Debug.Trace import Data.List import Control.Arrow import Control.Arrow.Transformer.All import Control.Arrow.Operations -type FormOut = Html ()+type FormOut = String newtype FormIn = FormIn [(String,String)] deriving (Show) type HoH i o = LabeledArrow (ReaderArrow FormIn (Automaton (Kleisli IO))) i o@@ -27,8 +26,7 @@ noInput = FormIn [] filterPrefix :: String -> FormIn -> FormIn-filterPrefix s (FormIn xss) = trace (show (s, xss)) $- FormIn $ filter ((== s) . fst) xss+filterPrefix s (FormIn xss) = FormIn $ filter ((== s) . fst) xss class HasFormOut o where getFormOut :: o -> FormOut@@ -94,6 +92,3 @@ (LabeledArrow $ proc (i,f') -> do (o,g) <- app -< (elimAutomaton $ unLA f', i) returnA -< (o, Just $ LabeledArrow g))--runHamlet :: (Arrow a) => a (x -> y) y-runHamlet = arr ($ undefined)
− Web/Horse/Hack.hs
@@ -1,104 +0,0 @@-{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, - NoMonomorphismRestriction #-}--module Web.Horse.Hack where-import Web.Horse.Forms-import Data.Time.Clock-import Data.Maybe-import Data.List-import Data.Function-import Text.Hamlet-import Web.Horse.Forms.Types-import Hack ( Env (..), Response (..) )-import Hack.Contrib.Request (cookies, params, inputs, path)-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as LB-import Control.Concurrent.MVar-import System.Random (randomIO)-import Control.Applicative-import Control.Arrow-import Control.Monad-import Data.List.Split (splitOn)-import Control.Arrow.Transformer.Automaton-import Control.Arrow.Transformer.Automaton.Maybe-import Control.Arrow.Transformer.Automaton.Monad-import Control.Arrow.Transformer.Reader-import Hack.Handler.EvHTTP (run)-import Control.Arrow.Transformer.LabeledArrow-import qualified Data.Map as M--type Url = [String]--runHorse f = runHorse1 run (simpleReqResp g)- where- g = runReader $ runLabeledArrow $ f - >>> arr renderHtml--runHorse1 :: ((Env -> IO Response) -> IO ()) -> - MaybeAutomaton (Kleisli IO) Env Response -> IO ()-runHorse1 runner f = do- mv <- newMVar []- runner (runWeb mv f)--sessionTarget = 150--runWeb- :: MVar [(String, MVar (Automaton (Kleisli IO) Env Response))]- -> MaybeAutomaton (Kleisli IO) Env Response- -> Env- -> IO Response-runWeb mv f0 req = do- compact mv- mv_sess <- getSessionMVar mv req- case mv_sess of- Just mv_sess -> modifyMVar mv_sess $ \sess -> do- (x,y) <- (runKleisli (auto sess) req)- return (y,x)- Nothing -> do- (resp,f') <- runKleisli (mAut f0) req- case f' of- Nothing -> return resp- Just f' -> do- (newSess :: Int) <- abs <$> randomIO- var <- newMVar f'- modifyMVar_ mv $ return . ((show newSess,var) :)- let cookie = ("Set-Cookie", - sessionName ++ "=" ++ show newSess ++ "; path=/")- print ("Set cookie " ++ show newSess)- return (resp{ headers=(cookie:headers resp) })- --compact mv = modifyMVar_ mv $ \lst ->- case length lst > (2 * sessionTarget) of- True -> return (take sessionTarget $ nubBy ((==) `on` fst) lst)- False -> return lst--getSessionMVar- :: MVar [(String, MVar (Automaton (Kleisli IO) Env Response))]- -> Env- -> IO (Maybe (MVar (Automaton (Kleisli IO) Env Response)))-getSessionMVar mv req = modifyMVar mv $ \lst -> do- case lookup sessionName (cookies req) of- Just sess -> case lookup sess lst of- Just val -> return ((sess,val):lst, Just val)- Nothing -> return (lst, Nothing)- Nothing -> return (lst, Nothing)--sessionName :: [Char]-sessionName = "HaskellOnAHorse"----simpleReqResp :: (Arrow a) => a (Url, FormIn) ByteString -> a Env Response-simpleReqResp f = proc req -> do- let u = filter (/= "") $ splitOn "/" (path req)- fi = FormIn $ params req ++ inputs req- fo <- f -< (u,fi)- returnA -< asResponse fo--asResponse :: ByteString -> Response-asResponse out = Response { status=200, headers=[typ,len], body = out }- where- typ = ("Content-Type", "text/html")- len = ("Content-Length", show $ LB.length out)-
+ Web/Horse/Server.hs view
@@ -0,0 +1,112 @@+{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, OverloadedStrings, NoMonomorphismRestriction #-}++module Web.Horse.Server where++import Web.Horse.Forms+import Web.Cookie (parseCookiesText)+import Data.Time.Clock+import Data.Maybe+import Data.Monoid+import Data.List+import Data.CaseInsensitive (mk, original)+import Control.Monad.IO.Class+import Data.Function+import Network.Wai.Handler.Warp+import Network.Wai+import Network.HTTP.Types+import Network.Wai.Parse+import Web.Horse.Forms.Types+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy.UTF8 (fromString)+import qualified Data.Text as T+import qualified Data.ByteString as SB+import qualified Data.ByteString.Char8 as SBC+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.Char8 as LBC+import Control.Concurrent.MVar+import System.Random (randomIO)+import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.List.Split (splitOn)+import Control.Arrow.Transformer.Automaton+import Control.Arrow.Transformer.Automaton.Maybe+import Control.Arrow.Transformer.Automaton.Monad+import Control.Arrow.Transformer.Reader+import Control.Arrow.Transformer.LabeledArrow+import qualified Data.Map as M++type Url = [String]++runHorse f = runHorse1 g+ where+ g = runReader $ runLabeledArrow $ f ++runHorse1 :: MaybeAutomaton (Kleisli IO) (Url, FormIn) String -> IO Application+runHorse1 f = do+ mv <- newMVar []+ return $ runWeb mv f++sessionTarget = 150++runWeb+ :: MVar [(String, MVar (Automaton (Kleisli IO) (Url, FormIn) String))]+ -> MaybeAutomaton (Kleisli IO) (Url, FormIn) String+ -> Application+runWeb mv f0 req = do+ liftIO $ compact mv+ mv_sess <- liftIO $ getSessionMVar mv req+ inp <- extractFormInputs req+ case mv_sess of+ Just mv_sess -> liftIO $ modifyMVar mv_sess $ \sess -> do+ (x,y) <- runKleisli (auto sess) inp+ return (y, asResponse x [])+ Nothing -> liftIO $ do+ (resp,f') <- runKleisli (mAut f0) inp+ case f' of+ Nothing -> return (asResponse resp [])+ Just f' -> do+ (newSess :: Int) <- abs <$> randomIO+ var <- newMVar f'+ modifyMVar_ mv $ return . ((show newSess,var) :)+ let cookie = ("Set-Cookie", mconcat [sessionName, "=", show newSess, "; path=/"])+ return (asResponse resp [cookie])+ ++compact mv = modifyMVar_ mv $ \lst ->+ case length lst > (2 * sessionTarget) of+ True -> return (take sessionTarget $ nubBy ((==) `on` fst) lst)+ False -> return lst++getSessionMVar+ :: MVar [(String, MVar (Automaton (Kleisli IO) (Url, FormIn) String))]+ -> Request+ -> IO (Maybe (MVar (Automaton (Kleisli IO) (Url, FormIn) String)))+getSessionMVar mv req = modifyMVar mv $ \lst -> do+ case lookup sessionName (getRequestCookies req) of+ Just sess -> case lookup sess lst of+ Just val -> return ((sess,val):lst, Just val)+ Nothing -> return (lst, Nothing)+ Nothing -> return (lst, Nothing)++sessionName :: [Char]+sessionName = "HaskellOnAHorse"++--extractFormInputs :: Request -> ResourceT IO (Url, FormIn)+extractFormInputs req = do+ let queryParams = map (\(x,y) -> (x,fromMaybe (SBC.pack "") y)) (queryString req)+ (params, _) <- parseRequestBody lbsBackEnd req+ return (map T.unpack (pathInfo req), FormIn $ (map (\(x,y) -> (SBC.unpack x, SBC.unpack y)) (queryParams ++ params)))++asResponse :: String -> [(String, String)] -> Response+asResponse out hdrs = responseLBS ok200 (map (\(x,y) -> (mk (SBC.pack x), SBC.pack y)) (typ:len:hdrs)) (fromString out)+ where+ typ = ("Content-Type", "text/html")+ len = ("Content-Length", show $ LB.length $ fromString out)+++getRequestCookies :: Request -> [(String, String)]+getRequestCookies req = + map (\(x,y) -> (T.unpack x, T.unpack y)) + $ parseCookiesText + $ fromMaybe "" (lookup "Cookie" (requestHeaders req))
on-a-horse.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.2+Version: 0.3 -- A short (one-line) description of the package. Synopsis: "Haskell on a Horse" - A combinatorial web framework@@ -25,7 +25,7 @@ License-file: LICENSE -- The package author(s).-Author: Jason Hart Priestley+Author: Jason Priestley -- An email address to which users can send suggestions, bug reports, -- and patches.@@ -56,12 +56,11 @@ Control.Arrow.Transformer.Automaton.Maybe -- Packages needed in order to build this package.- Build-depends: base >= 4 && < 5, safe, split, hamlet, hack, - hack-handler-evhttp, hack-contrib, containers, - arrows, mtl, random, bytestring, time+ Build-depends: base >= 4 && < 5, safe, split, warp, containers, text, utf8-string, case-insensitive,+ arrows, mtl, random, bytestring, time, wai-extra, cookie, http-types, wai, transformers -- Modules not exported by this package.- Other-modules: Web.Horse.Forms, Web.Horse.Hack, + Other-modules: Web.Horse.Forms, Web.Horse.Server, Web.Horse.Forms.Basic, Web.Horse.Forms.Types
tutorial.lhs view
@@ -10,7 +10,7 @@ .oper{ border: 1px solid; padding: 4px; } - .sourceCode{ background-color: #eee; border: 1px dotted #666; + .literate.haskell{ background-color: #eee; border: 1px dotted #666; padding: 8px; width: 100%; } .example{ background-color: #eee; width: 100%; border-collapse: collapse; }@@ -19,10 +19,18 @@ </style> Haskell on a Horse (HoH) is a combinatorial web framework for the-programming language Haskell. It is currently at an early, unsettled-stage of development. It is available under the "BSD3" open-source-license.+programming language Haskell. I developed it in 2010, but other+responsibilities prevented me from ever really finishing it - at this+point I have moved on to other projects. +The project remains interesting for various reasons - there is a+coroutine implementation in Control/Arrow/Transformer/Automaton/Monad,+the LabeledArrow and MaybeAutomaton classes are unique as far as I+know, and the compositional handling of web forms is, as far as I+know, more sophisticated than any other system.++If you'd like to browse the code, it is <a href="http://www.github.com/jhp/on-a-horse.html">available on github now</a>.+ Installing and Using HoH ------------------------ @@ -35,7 +43,9 @@ > import Control.Monad > import Control.Monad.Cont > import Data.Maybe+> import Network.Wai.Handler.Warp (run) > import Data.Monoid+> import qualified Data.Set as S > import Data.List.Split (splitOn) > import Control.Arrow.Transformer.All > import Text.Pandoc@@ -60,7 +70,9 @@ run this as a web app on port 8080 using ~~~~~~~~{.haskell}-main = runHorse ex1+main = do+ app <- runHorse ex1+ run 8080 app ~~~~~~~~ Side-by-Side Components@@ -70,7 +82,7 @@ <table class=example><tr><td> -> ex2 :: HoHMay Url (Html ())+> ex2 :: HoHMay Url String > ex2 = proc url -> do > (fo1, oper) <- enumForm "operation" > [("times", (*)),@@ -78,16 +90,14 @@ > (fo2, x::Maybe Integer) <- readForm "x" -< () > (fo3, y::Maybe Integer) <- readForm "y" -< () > let result = show <$> (oper <*> x <*> y)-> runHamlet -< [$hamlet|-> %form!method=POST!action=""-> Calculate a number!-> %br-> $fo1$ $fo2$ $fo3$-> Result:-> $maybe result res-> $res$-> %br-> %input!type=submit |]+> returnA -< wrapForm $ mconcat [+> "Calculate a number!",+> "<br/>",+> fo1, fo2, fo3,+> "Result:",+> fromMaybe "" result,+> "<br/>"+> ] </td><td>EXAMPLE</td></tr></table> @@ -111,7 +121,7 @@ <table class=example><tr><td> -> ex3 :: HoHMay Url (Html ())+> ex3 :: HoHMay Url String > ex3 = formSum "example to run" [("example 1",ex1),("example 2",ex2)] mempty > >>> arr wrapForm @@ -127,14 +137,7 @@ > ex4 = proc url -> do > (fo,result) <- term "expression" -< ()-> runHamlet -< [$hamlet|-> %form!method=POST!action=""-> $fo$-> Result:-> $maybe result res-> $show res$ -> %input!type=submit-> %br |]+> returnA -< wrapForm $ mconcat [fo, "Result:", maybe "" show result, "<br/>"] > where > term :: String -> HoHMay () (FormOut, Maybe Integer) > term label = catchMayAuto $ formSum label @@ -153,12 +156,7 @@ > (fo1) <- linkForm "cancel" (term termLabel) -< () > (fo2,x) <- liftError (term "x") -< () > (fo3,y) <- liftError (term "y") -< ()-> out <- runHamlet -< [$hamlet|-> %div.oper-> $fo1$-> $label$-> %br-> $fo2$ $fo3$ |]+> out <- returnA -< mconcat $ ["<div class=\"oper\">", fo1, label, "<br/>", fo2, fo3] > returnA -< (out, f <$> x <*> y) </td><td>EXAMPLE</td></tr></table>@@ -216,20 +214,15 @@ </td><td>EXAMPLE</td></tr></table> > fourOhFour = proc url -> do-> runHamlet -< [$hamlet| Page not found |]+> returnA -< "Page not found" > urls = proc url -> do-> runHamlet -< [$hamlet|-> %a!href=ex1 example 1-> %br-> %a!href=ex2 example 2-> %br-> %a!href=ex3 example 3-> %br-> %a!href=ex4 example 4-> %br-> %a!href=ex5 example 5-> %br |]+> returnA -< mconcat [+> "<a href=\"/ex1\">example 1</a><br/>",+> "<a href=\"/ex2\">example 2</a><br/>",+> "<a href=\"/ex3\">example 3</a><br/>",+> "<a href=\"/ex4\">example 4</a><br/>"+> ] > Running the Tutorial@@ -241,22 +234,21 @@ > main = do > tut <- readFile "tutorial.lhs" > tmpl <- getDefaultTemplate Nothing "html"-> let pd = readMarkdown defaultParserState{ stateLiterateHaskell=True } tut-> let tut' = writeHtmlString defaultWriterOptions{+> let pd = readMarkdown def{readerExtensions = S.insert Ext_literate_haskell (readerExtensions def)} tut+> let tut' = writeHtmlString def{ > writerStandalone=True, > writerTemplate= either (error . show) id tmpl > } pd-> let ts = map preEscapedString $ splitOn ("EXA"++"MPLE") tut'-> runHorse $ proc url -> do+> let ts = splitOn ("EXA"++"MPLE") tut'+> app <- runHorse $ proc url -> do > fo1 <- ex1 -< url > fo2 <- ex2 -< url > fo3 <- ex3 -< url > fo4 <- ex4 -< url > fo5 <- ex5 -< url > let vals = interleave ts [fo1,fo2,fo3,fo4,fo5]-> runHamlet -< [$hamlet|-> $forall vals val-> $val$ |]+> returnA -< mconcat vals +> run 8000 app > interleave (x:xs) (y:ys) = (x:y:interleave xs ys) > interleave [] ys = ys@@ -264,6 +256,6 @@ <b> -> -- Jason Hart Priestley, July 26, 2010. (jason @ this domain)+> -- Jason Priestley, July 26, 2010. (jason @ this domain) </b>