T5045.hs 1.28 KB
Newer Older
simonpj's avatar
simonpj committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
{-# LANGUAGE Arrows, FunctionalDependencies, FlexibleContexts, 
             MultiParamTypeClasses, RecordWildCards  #-}

module T5045 where

import Control.Arrow

class (Control.Arrow.Arrow a') => ArrowAddReader r a a' | a -> a' where
  elimReader :: a e b -> a' (e, r) b

newtype ByteString = FakeByteString String

pathInfo :: Monad m => m String
pathInfo = undefined

requestMethod :: Monad m => m String
requestMethod = undefined

getInputsFPS :: Monad m => m [(String, ByteString)]  
getInputsFPS = undefined

class HTTPRequest r s | r -> s where
    httpGetPath :: r -> String
    httpSetPath :: r -> String -> r
    httpGetMethod :: r -> String
    httpGetInputs :: r -> [(String, s)]

data CGIDispatch = CGIDispatch {
    dispatchPath :: String,
    dispatchMethod :: String,
    dispatchInputs :: [(String, ByteString)]  }

instance HTTPRequest CGIDispatch ByteString where
    httpGetPath = dispatchPath
    httpSetPath r s = r { dispatchPath = s }
    httpGetMethod = dispatchMethod
    httpGetInputs = dispatchInputs

runDispatch :: (Arrow a, ArrowAddReader CGIDispatch a a', Monad m) => a b  c -> m (a' b c)  
runDispatch a = do
    dispatchPath <- pathInfo
    dispatchMethod <- requestMethod
    dispatchInputs <- getInputsFPS
    return $ proc b -> (| elimReader (a -< b) |) CGIDispatch { .. }