on-a-horse (empty) → 0.1
raw patch · 11 files changed
+990/−0 lines, 11 filesdep +arrowsdep +basedep +bytestringsetup-changed
Dependencies added: arrows, base, bytestring, containers, hack, hack-contrib, hack-handler-evhttp, hamlet, mtl, random, safe, split
Files
- Control/Arrow/Transformer/Automaton/Monad.hs +150/−0
- Control/Arrow/Transformer/LabeledArrow.hs +126/−0
- LICENSE +30/−0
- Setup.hs +3/−0
- Web/Horse.hs +12/−0
- Web/Horse/Forms.hs +128/−0
- Web/Horse/Forms/Basic.hs +51/−0
- Web/Horse/Forms/Types.hs +70/−0
- Web/Horse/Hack.hs +82/−0
- on-a-horse.cabal +69/−0
- tutorial.lhs +269/−0
+ Control/Arrow/Transformer/Automaton/Monad.hs view
@@ -0,0 +1,150 @@+{-#LANGUAGE Arrows, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,+ UndecidableInstances, FunctionalDependencies, NoMonomorphismRestriction #-}++module Control.Arrow.Transformer.Automaton.Monad+ (monadToAuto, co, autoToMonad, readerArrow, swapsnd,+ pushError,popError,rstrength,+ ArrowAddAutomaton (..), dispatch) where++import Control.Monad+import Control.Monad.Cont+import Control.Monad.State (MonadState (..))++import Control.Arrow+import Control.Arrow.Operations+import qualified Control.Arrow.Transformer as AT+import Control.Arrow.Transformer.All++import Data.Maybe+import qualified Data.Map as M++unAM (ArrowMonad f) = f++monadToAuto+ :: (ArrowAddAutomaton a a', ArrowApply a') =>+ (i -> ContT (o, a i o) (ArrowMonad a') z) -> a i o+monadToAuto f = liftAutomaton (proc i -> + unAM ((f i) `runContT` (error "automaton ended")) -<< ())+++co+ :: (ArrowApply a', ArrowAddAutomaton a a') =>+ o -> ContT (o, a i o) (ArrowMonad a') i+co o = ContT (\fi -> + return (o, liftAutomaton (proc i -> unAM (fi i) -<< ())))++autoToMonad+ :: (ArrowApply a', ArrowAddAutomaton a a') =>+ a i (Either o z)+ -> i+ -> ContT (o, a i o) (ArrowMonad a') z+autoToMonad f i = do+ x <- lift $ ArrowMonad $ (proc () -> elimAutomaton f -< i)+ case x of+ (Right z,_) -> return z+ (Left o,f') -> autoToMonad f' =<< co o++++class ArrowAddAutomaton a a' | a -> a' where+ elimAutomaton :: a i o -> a' i (o, a i o)+ liftAutomaton :: a' i (o, a i o) -> a i o+ constantAutomaton :: a' i o -> a i o++instance (Arrow a) => ArrowAddAutomaton (Automaton a) a where+ elimAutomaton (Automaton f) = f+ liftAutomaton = Automaton+ constantAutomaton f = Automaton (f >>> + arr (flip (,) (constantAutomaton f)))++instance (Arrow a, Arrow a', ArrowAddAutomaton a a') + => ArrowAddAutomaton (StateArrow s a) (StateArrow s a') where+ elimAutomaton = autoState . elimAutomaton . runState + liftAutomaton = stateArrow . liftAutomaton . stateAuto+ constantAutomaton = stateArrow . constantAutomaton . runState+ ++instance (ArrowState s a, ArrowApply a) => (MonadState s (ArrowMonad a)) where+ put s = ArrowMonad (proc () -> store -< s)+ get = ArrowMonad fetch++instance (Arrow a, Arrow a', ArrowAddAutomaton a a') + => ArrowAddAutomaton (ReaderArrow r a) (ReaderArrow r a') where+ elimAutomaton = (>>> (second (arr readerArrow))) . + readerArrow . elimAutomaton . runReader++ liftAutomaton = readerArrow . liftAutomaton . + (>>> (second (arr runReader))) . runReader+ + constantAutomaton = readerArrow . constantAutomaton . runReader++instance (ArrowChoice a, ArrowChoice a', ArrowAddAutomaton a a')+ => ArrowAddAutomaton (ErrorArrow ex a) (ErrorArrow ex a') where+ elimAutomaton = pushError . + (>>> second (arr pushError) >>> arr rstrength) + . elimAutomaton . popError++ liftAutomaton f = + pushError $ liftAutomaton $+ (>>> arr (revrstrength (liftAutomaton f)) + >>> second (arr popError)) + $ popError f++ constantAutomaton = pushError . constantAutomaton . popError+++dispatch = dispatch0 M.empty++dispatch0+ :: (Ord k,+ ArrowAddAutomaton a a',+ ArrowApply a') =>+ M.Map k (a i o) -> (k -> a i o) -> a (i, k) o+dispatch0 mp def = liftAutomaton $ proc (i,k) -> do+ let f = fromMaybe (def k) (M.lookup k mp)+ (o,f') <- app -< (elimAutomaton f,i)+ returnA -< (o, dispatch0 (M.insert k f' mp) def)+ ++--Utility functions++swapsnd :: ((a, b), c) -> ((a, c), b)+swapsnd ~(~(x, y), z) = ((x, z), y)++rstrength :: (Either ex a, b) -> Either ex (a, b)+rstrength (Left ex, _) = Left ex+rstrength (Right a, b) = Right (a, b)++revrstrength :: b -> Either ex (a,b) -> (Either ex a, b)+revrstrength def (Left ex) = (Left ex, def)+revrstrength _ (Right (a,b)) = (Right a, b)++autoState :: (Arrow a, Arrow a') => a' (i,s) ((o,s), a (i,s) (o,s)) -> + StateArrow s a' i (o,StateArrow s a i o)+autoState f = stateArrow $ f >>> second (arr stateArrow) >>> arr swapsnd++stateAuto :: (Arrow a, Arrow a') => StateArrow s a' i (o,StateArrow s a i o) ->+ a' (i,s) ((o,s), a (i,s) (o,s))+stateAuto f = runState (f >>> second (arr runState)) >>> arr swapsnd+++--simulating the unexported data constructors for StateArrow,+--ReaderArrow, ErrorArrow++stateArrow :: (Arrow a) => a (t, s) (b, s) -> StateArrow s a t b+stateArrow f = proc i -> do+ s <- fetch -< ()+ (o,s') <- AT.lift f -< (i,s)+ store -< s'+ returnA -< o++readerArrow :: (Arrow a) => a (e,r) b -> ReaderArrow r a e b+readerArrow f = proc i -> do+ r <- readState -< ()+ AT.lift f -< (i,r)++popError :: (ArrowChoice a) => ErrorArrow ex a e b -> a e (Either ex b)+popError f = runError (f >>> arr Right) (arr snd >>> arr Left)++pushError :: (ArrowChoice a) => a e (Either ex b) -> ErrorArrow ex a e b+pushError f = (AT.lift f) >>> (raise ||| arr id)
+ Control/Arrow/Transformer/LabeledArrow.hs view
@@ -0,0 +1,126 @@+{-#LANGUAGE Arrows, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,+ UndecidableInstances, FunctionalDependencies, NoMonomorphismRestriction #-}++module Control.Arrow.Transformer.LabeledArrow where++import qualified Control.Category as C+import Control.Monad+import Control.Monad.Cont++import Control.Arrow+import Control.Arrow.Operations+import qualified Control.Arrow.Transformer as AT+import Control.Arrow.Transformer.All+import Control.Arrow.Transformer.Automaton.Monad++import Data.Maybe+import Data.List+import Data.List.Split (splitOn)+import qualified Data.Map as M++newtype Label = Label Integer++base64 = "abcdefghijklmnopqrstuvwxyz"+++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"+++ "1234567890_:"++instance Show Label where+ show (Label 0) = ""+ show (Label n) = [(base64 !! fromIntegral mod)] ++ show (Label div)+ where+ (div,mod) = divMod n 64+ +instance Read Label where+ readsPrec _ s = case read64 s of+ Just x -> [(Label x, "")]+ Nothing -> []++read64 [] = Just 0+read64 (c:cs) = case lookup c (zip base64 [0..]) of+ Just n -> fmap (\k -> n + 64*k) (read64 cs)+ Nothing -> Nothing++alterReader q f = proc i -> do+ s <- readState -< ()+ newReader f -< (i,q s)++pushId x = alterReader (\(Label z) -> Label (2*z + x))++class (Arrow a, Arrow a') => ArrowAddLabel a a' | a -> a' where+ runLabel :: a' (e,Label) b -> a e b++instance Arrow a => ArrowAddLabel (LabeledArrow a) a where+ runLabel = runArrowLabel++instance (ArrowAddLabel a a') => + ArrowAddLabel (ReaderArrow r a) (ReaderArrow r a') where+ runLabel f = readerArrow $ runLabel (arr swapsnd >>> runReader f)++instance (ArrowAddLabel a a',ArrowChoice a, ArrowChoice a') => + ArrowAddLabel (ErrorArrow ex a) (ErrorArrow ex a') where+ runLabel f = pushError $ runLabel $ popError f++instance ArrowReader r a => ArrowReader r (LabeledArrow a) where+ readState = LabeledArrow (AT.lift readState)+ newReader (LabeledArrow f) = LabeledArrow $ readerArrow $ + arr (swapsnd) >>> newReader (runReader f) ++runArrowLabel f = LabeledArrow (proc e -> do+ lab <- readState -< ()+ AT.lift f -< (e,lab))++newtype LabeledArrow a i o = LabeledArrow (ReaderArrow Label a i o)++unLA (LabeledArrow f) = f++runLabeledArrow (LabeledArrow f) = proc i -> do+ runReader f -< (i,Label 1)++instance (C.Category a, Arrow a) => C.Category (LabeledArrow a) where+ (.) (LabeledArrow f) (LabeledArrow g) = + LabeledArrow $ (C..) (pushId 1 f) (pushId 0 g)+ id = LabeledArrow (C.id)++instance Arrow a => Arrow (LabeledArrow a) where+ arr = LabeledArrow . arr+ (***) (LabeledArrow f) (LabeledArrow g) = + LabeledArrow $ (pushId 0 f *** pushId 1 g)+ first f = f *** (arr id)++instance (Arrow a, Arrow a', ArrowAddAutomaton a a') =>+ ArrowAddAutomaton (LabeledArrow a) (LabeledArrow a') where+ liftAutomaton (LabeledArrow f) = + LabeledArrow $ liftAutomaton (f >>> second (arr unLA))++ elimAutomaton (LabeledArrow f) = + LabeledArrow $ elimAutomaton f >>> second (arr LabeledArrow)++ constantAutomaton = LabeledArrow . constantAutomaton . unLA++instance (ArrowError ex a) => (ArrowError ex (LabeledArrow a)) where+ raise = LabeledArrow raise+ tryInUnless f g h = LabeledArrow $ tryInUnless (unLA f) (unLA g) (unLA h)++instance (ArrowAddError ex a a') + => ArrowAddError ex (LabeledArrow a) (LabeledArrow a')+ where+ liftError = LabeledArrow . liftError . unLA+ elimError (LabeledArrow f) (LabeledArrow h) = + LabeledArrow $ elimError f h++instance (ArrowApply a) => ArrowApply (LabeledArrow a) where+ app = LabeledArrow (first (arr unLA) >>> app)++instance ArrowChoice a => ArrowChoice (LabeledArrow a) where+ (+++) (LabeledArrow f) (LabeledArrow g) = + LabeledArrow $ pushId 0 f +++ pushId 1 g++ left f = f +++ arr id+++writeState l = LabeledArrow (proc i -> do+ s <- readState -< ()+ AT.lift (Kleisli (print)) -< (l,s))++foo = (`runKleisli` ()) $ runLabeledArrow $ + ( writeState "a" >>> writeState "b" >>> writeState "c")
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Jason Hart Priestley 2010++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 Jason Hart Priestley 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 view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ Web/Horse.hs view
@@ -0,0 +1,12 @@+module Web.Horse + (module Text.Hamlet, module Web.Horse.Forms.Types, + module Web.Horse.Forms.Basic, module Web.Horse.Forms, + module Web.Horse.Hack, + 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 Control.Arrow.Transformer.Automaton.Monad
+ Web/Horse/Forms.hs view
@@ -0,0 +1,128 @@+{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, FlexibleContexts,+ TypeSynonymInstances, NoMonomorphismRestriction, FlexibleInstances #-}++module Web.Horse.Forms where++import Web.Horse.Forms.Types+import Web.Horse.Forms.Basic+import Data.Monoid+import Data.List.Split (splitOn)+import Safe (readMay)+import Text.Hamlet+import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.Maybe+import Data.Char+import Control.Arrow.Transformer.All+import Control.Arrow.Transformer.Automaton.Monad+import Control.Arrow.Transformer.LabeledArrow+import Control.Arrow.Operations hiding (write)++import Debug.Trace++valForm+ :: (ArrowReader FormIn a',+ ArrowAddLabel a a',+ ArrowApply a'1,+ ArrowAddAutomaton a' a'1,+ ArrowChoice a') =>+ String+ -> a' String (Either String a1)+ -> String+ -> a () (Html (), Maybe a1)+valForm initVal vtor label = withInput $+ proc ((),nm,fi) -> do+ s_curr <- keepState initVal -< fi+ valid <- vtor -< s_curr+ case valid of+ Left err -> returnA -< (textField label (Just err) s_curr nm, + Nothing)+ Right x -> returnA -< (textField label Nothing s_curr nm,+ Just x)++stringForm = valForm "" (arr Right)++readForm = valForm "" (arr (\x -> maybe (Left ("No read: " ++ x)) Right (readMay x)))++enumForm label vs = withInput $+ (proc ((),nm,fi) -> do+ n_curr <- keepState (-1) -< extractNumber fi+ let n_val = max n_curr 0+ res = if n_curr < 0 then Nothing else (Just $ snd $ vs !! n_curr)+ returnA -< (select label (map fst vs) n_val nm, res))+ where+ extractNumber i = checkBounds $ readMay =<< i++ checkBounds Nothing = Nothing+ checkBounds (Just k) = if k >= 0 && k < length vs + then Just k else Nothing++runSubStream :: (ArrowChoice a) => a i o -> a (Maybe i) (Maybe o)+runSubStream f = proc i -> + case i of+ Just i' -> f >>> (arr Just) -< i'+ Nothing -> returnA -< Nothing++filterDiffs+ :: (Eq i, ArrowApply a', ArrowAddAutomaton a a') => a i (Maybe i)+filterDiffs = monadToAuto $ \i1 -> do+ i2 <- co (Just i1)+ runFilter i1 i2+ where+ runFilter i1 = \i2 -> do+ case i1 == i2 of+ True -> runFilter i1 =<< co Nothing+ False -> runFilter i2 =<< co (Just i2)++keepState :: (ArrowApply a', ArrowAddAutomaton a a') => o -> a (Maybe o) o+keepState s0 = monadToAuto (f s0)+ where+ f s0' ms1 = f (fromMaybe s0' ms1) =<< co (fromMaybe s0' ms1)+++replaceSecond+ :: (ArrowAddAutomaton a a', ArrowApply a') =>+ a i o -> a (i, Maybe (a i o)) o+replaceSecond g = liftAutomaton $ + (proc (i,g_new) -> do+ let g_curr = elimAutomaton (fromMaybe g g_new)+ (o,g') <- g_curr -<< i+ returnA -< (o, replaceSecond g'))+ +once :: (ArrowAddAutomaton a a', ArrowApply a') => a1 -> a i (Maybe a1)+once x = monadToAuto $ \_ -> co (Just x) >> forever (co (Nothing))++auto :: Automaton a i o -> a i (o, Automaton a i o)+auto (Automaton f) = f+++++formSum _ [] _ = error "formSum requires at least one argument"++formSum label fs def = catchAuto $ proc _ -> do+ (fo,f) <- enumForm label fs -< ()+ case f of+ Just f' -> throwAuto -< f'+ Nothing -> returnA -< setFormOut fo def+++throwAuto = proc f -> do+ raise -< liftAutomaton $ LabeledArrow $+ (arr (flip (,) noInput) + >>> (unLA (newReader (elimAutomaton f))))++linkForm linkName f = withInput $ proc ((),nm,iname) -> do+ case iname of+ Just _ -> throwAuto -< f+ Nothing -> returnA -< (link linkName nm)++++staticUrls :: a -> [(String, a)] -> ([String] -> a)+staticUrls def fs s = + case lookup (filter (/= "") $ map (map toLower) s) + (map ((filter (/= "") . splitOn "/") *** id) fs) of+ Nothing -> def+ Just f -> f
+ Web/Horse/Forms/Basic.hs view
@@ -0,0 +1,51 @@+{-#LANGUAGE ScopedTypeVariables, QuasiQuotes, OverloadedStrings #-}++module Web.Horse.Forms.Basic where++import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy.Char8 ()+import Text.Hamlet+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|]++link :: String -> String -> Html ()+link linkName name = ($ undefined) $ [$hamlet|+ %a!href="?$name$=1" $linkName$+ %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 |]+ where+ opts = (zip3 (map (==val) [0..]) (map show [(0::Int)..]) options)+ isSelected (x,_,_) = x+ num (_,y,_) = y+ optVal (_,_,z) = z++++wrapForm :: Html () -> Html ()+wrapForm f = mconcat [preEscapedString "<form method='POST' action=''>", f, + preEscapedString "<input type='submit'></input></form>"]++
+ Web/Horse/Forms/Types.hs view
@@ -0,0 +1,70 @@+{-#LANGUAGE Arrows, TypeSynonymInstances, FlexibleInstances,+ FlexibleContexts #-}++module Web.Horse.Forms.Types where++import Control.Arrow.Transformer.Automaton.Monad+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 ()+newtype FormIn = FormIn [(String,String)] deriving (Show)++type HoH i o = LabeledArrow (ReaderArrow FormIn (Automaton (Kleisli IO))) i o++type WithError ex i o = LabeledArrow (ErrorArrow ex (ReaderArrow FormIn (Automaton (Kleisli IO)))) i o++noInput :: FormIn+noInput = FormIn [] ++filterPrefix :: String -> FormIn -> FormIn+filterPrefix s (FormIn xss) = FormIn $ filter ((== s) . fst) xss++class HasFormOut o where+ getFormOut :: o -> FormOut+ setFormOut :: FormOut -> o -> o++instance HasFormOut FormOut where+ getFormOut = id+ setFormOut = const++instance HasFormOut (FormOut, i) where+ getFormOut (fo,_) = fo+ setFormOut fo (_,o) = (fo,o)++instance HasFormOut (FormOut, o1, o2) where+ getFormOut (fo,_,_) = fo+ setFormOut fo (_,o1,o2) = (fo,o1,o2)+++getSingle :: FormIn -> Maybe String+getSingle (FormIn [(_,x)]) = Just x+getSingle _ = Nothing++withInput :: (ArrowReader FormIn a', ArrowAddLabel a a')+ => a' (e,String,Maybe String) b -> a e b+withInput f = runLabel $ proc (e,lab) -> do+ fi <- readState -< ()+ f -< (e,show lab,getSingle $ filterPrefix (show lab) fi)++catchAuto+ :: (ArrowAddAutomaton a a', + ArrowApply a',+ ArrowChoice a', + ArrowChoice a) =>+ (LabeledArrow (ErrorArrow (LabeledArrow a i o) a)) i o + -> LabeledArrow a i o+catchAuto f = liftAutomaton $+ (LabeledArrow $+ unLA (elimAutomaton f) + >>> second (arr catchAuto)) `elimError` + (LabeledArrow $ proc (i,f') -> + app -< (unLA (elimAutomaton f'), i))++runHamlet :: (Arrow a) => a (x -> y) y+runHamlet = arr ($ undefined)
+ Web/Horse/Hack.hs view
@@ -0,0 +1,82 @@+{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, + NoMonomorphismRestriction #-}++module Web.Horse.Hack where+import Web.Horse.Forms+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.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 ()) -> + Automaton (Kleisli IO) Env Response -> IO ()+runHorse1 runner f = do+ mv <- newMVar M.empty+ runner (runWeb mv f)++runWeb+ :: MVar (M.Map String (MVar (Automaton (Kleisli IO) Env Response)))+ -> Automaton (Kleisli IO) Env Response+ -> Env+ -> IO Response+runWeb mv f0 req = do+ (mv_sess, cookie) <- getSessionMVar mv f0 req+ sess <- takeMVar mv_sess + (resp,sess') <- runKleisli (auto sess) req + putMVar mv_sess sess'+ return (resp{ headers= cookie ++ headers resp }) ++getSessionMVar+ :: MVar (M.Map String (MVar a))+ -> a+ -> Env+ -> IO (MVar a, [(String, String)])+getSessionMVar mv f0 req = do+ let sess = lookup sessionName (cookies req)+ mp <- takeMVar mv+ case join $ M.lookup <$> sess <*> (Just mp) of+ Just val -> putMVar mv mp >> return (val,[])+ Nothing -> do+ (newSess :: Int) <- abs <$> randomIO+ var <- newMVar f0+ putMVar mv (M.insert (show newSess) var mp)+ return (var, [("Set-Cookie", + sessionName ++ "=" ++ show newSess ++ "; path=/")]) ++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)+
+ on-a-horse.cabal view
@@ -0,0 +1,69 @@+-- on-a-horse.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: on-a-horse++-- 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.1++-- A short (one-line) description of the package.+Synopsis: "Haskell on a Horse" - A combinatorial web framework++-- A longer description of the package.+Description: Please read the introduction at http://haskell.on-a-horse.org++-- URL for the project homepage or repository.+Homepage: haskell.on-a-horse.org++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Jason Hart Priestley++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: jason@on-a-horse.org++-- A copyright notice.+-- Copyright: ++-- Stability of the pakcage (experimental, provisional, stable...)+Stability: Experimental++Category: Web++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files: tutorial.lhs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.2+++Library+ -- Modules exported by the library.+ Exposed-modules: Web.Horse, Control.Arrow.Transformer.LabeledArrow,+ Control.Arrow.Transformer.Automaton.Monad+ + -- 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+ + -- Modules not exported by this package.+ Other-modules: Web.Horse.Forms, Web.Horse.Hack, + Web.Horse.Forms.Basic, Web.Horse.Forms.Types+ + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +
+ tutorial.lhs view
@@ -0,0 +1,269 @@+Haskell on a Horse+==================++ <style>+ body{ margin-left:40px; margin-right: 15%; text-align: justify; }+ .error{ color: red; }+ h1,h2 { font-family; sans-serif; font-weight: normal; color: #222; }+ h1{ font-size: 22pt; border-bottom: double }+ h2{ font-size: 18pt; border-bottom: 3px dotted }++ .oper{ border: 1px solid; padding: 4px; }++ .sourceCode{ background-color: #eee; border: 1px dotted #666; + padding: 8px; width: 100%; }+ .example{ background-color: #eee; width: 100%; + border-collapse: collapse; }+ .example td { border: 1px dotted #666; padding: 8px; }+ .example .sourceCode{ border: none; padding: 0; }+ </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.++Installing and Using HoH+------------------------++ cabal install on-a-horse++> {-#LANGUAGE Arrows, QuasiQuotes, ScopedTypeVariables #-}+> import Web.Horse +> import Control.Applicative+> import Control.Arrow+> import Control.Monad+> import Control.Monad.Cont+> import Data.Maybe+> import Data.Monoid+> import Data.List.Split (splitOn)+> import Control.Arrow.Transformer.All+> import Text.Pandoc++Atomic Components+-------------------++An HoH application is built up from atomic components. A component is+a complete HoH application all by itself: it can render itself, and+respond to input.++ <table class="example"><tr><td>++> +> ex1 = proc url -> do+> (fo,num::Maybe Integer) <- readForm "enter a number" -< ()+> returnA -< wrapForm fo+> ++ </td><td>EXAMPLE</td></tr></table>++run this as a web app on port 8080 using++~~~~~~~~{.haskell}+main = runHorse ex1+~~~~~~~~++Side-by-Side Components+--------------------------++Components can be rendered side-by-side within a page.++ <table class=example><tr><td>++> ex2 :: HoH Url (Html ())+> ex2 = proc url -> do+> (fo1, oper) <- enumForm "operation" +> [("times", (*)),+> ("plus", (+))] -< ()+> (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 |]++ </td><td>EXAMPLE</td></tr></table>++Replacing one Component With Another+---------------------------------------++Components can be replaced. A call to the arrow `throwAuto` will+replace the nearest enclosing `catchAuto`. The new component will be+called immediately, with no form input.++~~~~~~{.haskell}+formSum label fs def = catchAuto $ proc _ -> do+ (fo,f) <- enumForm label fs -< ()+ case f of+ Just f' -> throwAuto -< f'+ Nothing -> returnA -< setFormOut fo def+~~~~~~++Note: `def` is a default value to be used when no form is yet+selected.++ <table class=example><tr><td>++> ex3 :: HoH Url (Html ())+> ex3 = formSum "example to run" [("example 1",ex1),("example 2",ex2)] mempty+> >>> arr wrapForm++ </td><td>EXAMPLE</td></tr></table>++A More Complex Example+-------------------------++By combining the techniques above, sophisticated pages can be made+with little code. ++ <table class=example><tr><td>++> 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 |]+> where+> term :: String -> HoH () (FormOut, Maybe Integer)+> term label = catchAuto $ formSum label +> [("number", number label),+> ("add",oper label "add" (+)),+> ("multiply",oper label "multiply" (*))] (mempty, Nothing)+>+> number :: String -> WithError (HoH () (FormOut, Maybe Integer)) +> () (FormOut, Maybe Integer)+> number termLabel = proc () -> do+> fo1 <- linkForm "cancel" (term termLabel) -< ()+> (fo2,x) <- readForm "number" -< ()+> returnA -< (fo1 `mappend` fo2, x)+>+> oper termLabel label f = proc () -> do+> (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$ |]+> returnA -< (out, f <$> x <*> y)++ </td><td>EXAMPLE</td></tr></table>++Notes: ++* `throwAuto` works by adding an ErrorArrow to its argument.+When it is called recursively, as in the example above, `liftError`+may be required to avoid an infinite type.++* `linkForm` acts much like `throwAuto`, except that it waits to throw+its argument until the link it renders has been clicked.+++++Building Atomic Components+-------------------------++Atomic components should generally use the 'withInput' function. This+will add two inputs to an arrow: the first is a unique label for the+component, and the second is the current input to the arrow, or+Nothing if there is no input. The label should be used as a name in+any form input or query parameters. Here is the code for `linkForm`.++~~~~~~{.haskell}+linkForm linkName f = withInput $ proc ((),nm,iname) -> do+ case iname of+ Just _ -> throwAuto -< f+ Nothing -> returnA -< (link linkName nm)+~~~~~~++(`link "name" "label"` produces `<a href="?label=1">name</a>`)+++Handling urls+-------------++`runHorse` sends the URL as the sole argument to the handler. A+function, `dispatch`, is available to construct multi-page+applications.+++ + <table class="example"><tr><td>++> ex5 = proc url -> do+> (dispatch $ staticUrls fourOhFour $+> [("", urls),+> ("ex1", ex1),+> ("ex2", ex2),+> ("ex3", ex3),+> ("ex4", ex4)]) -< (url,url)++ </td><td>EXAMPLE</td></tr></table>++> fourOhFour = proc url -> do+> runHamlet -< [$hamlet| 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 |]+>++Running the Tutorial+--------------------++This tutorial is a sort of self-executing markdown (pandoc) file.+This is the code to run it.++> main = do+> tut <- readFile "tutorial.lhs"+> tmpl <- getDefaultTemplate Nothing "html"+> let pd = readMarkdown defaultParserState{ stateLiterateHaskell=True } tut+> let tut' = writeHtmlString defaultWriterOptions{+> writerStandalone=True,+> writerTemplate= either (error . show) id tmpl+> } pd+> let ts = map preEscapedString $ splitOn ("EXA"++"MPLE") tut'+> 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$ |]++> interleave (x:xs) (y:ys) = (x:y:interleave xs ys)+> interleave [] ys = ys+> interleave xs [] = xs++ <b>++> -- Jason Hart Priestley, July 26, 2010. (jason @ this domain)++ </b>