Vastly simplified Web.Restful.Application
This commit is contained in:
Michael Snoyman
parent
c4eb5e1ee7
commit
cb963a6231
93
Data/Object/Instances.hs
Normal file
93
Data/Object/Instances.hs
Normal file
@ -0,0 +1,93 @@
|
|||||||
|
---------------------------------------------------------
|
||||||
|
--
|
||||||
|
-- Module : Data.Object.Instances
|
||||||
|
-- Copyright : Michael Snoyman
|
||||||
|
-- License : BSD3
|
||||||
|
--
|
||||||
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||||
|
-- Stability : Stable
|
||||||
|
-- Portability : portable
|
||||||
|
--
|
||||||
|
-- Instances for converting various types of data into Data.Object.Object.
|
||||||
|
--
|
||||||
|
---------------------------------------------------------
|
||||||
|
module Data.Object.Instances
|
||||||
|
( Json (..)
|
||||||
|
, Yaml (..)
|
||||||
|
, Html (..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Object
|
||||||
|
import qualified Data.ByteString as B
|
||||||
|
import Data.ByteString.Class
|
||||||
|
import Web.Encodings (encodeJson)
|
||||||
|
import qualified Text.Yaml as Y
|
||||||
|
|
||||||
|
newtype Json = Json B.ByteString
|
||||||
|
instance FromObject Json where
|
||||||
|
fromObject = return . Json . helper where
|
||||||
|
helper :: Object -> B.ByteString
|
||||||
|
helper (Scalar s) = B.concat
|
||||||
|
[ toStrictByteString "\""
|
||||||
|
, encodeJson $ fromStrictByteString s
|
||||||
|
, toStrictByteString "\""
|
||||||
|
]
|
||||||
|
helper (Sequence s) = B.concat
|
||||||
|
[ toStrictByteString "["
|
||||||
|
, B.intercalate (toStrictByteString ",") $ map helper s
|
||||||
|
, toStrictByteString "]"
|
||||||
|
]
|
||||||
|
helper (Mapping m) = B.concat
|
||||||
|
[ toStrictByteString "{"
|
||||||
|
, B.intercalate (toStrictByteString ",") $ map helper2 m
|
||||||
|
, toStrictByteString "}"
|
||||||
|
]
|
||||||
|
helper2 :: (B.ByteString, Object) -> B.ByteString
|
||||||
|
helper2 (k, v) = B.concat
|
||||||
|
[ toStrictByteString "\""
|
||||||
|
, encodeJson $ fromStrictByteString k
|
||||||
|
, toStrictByteString "\":"
|
||||||
|
, helper v
|
||||||
|
]
|
||||||
|
|
||||||
|
newtype Yaml = Yaml B.ByteString
|
||||||
|
instance FromObject Yaml where
|
||||||
|
fromObject = return . Yaml . Y.encode
|
||||||
|
|
||||||
|
-- | Represents as an entire HTML 5 document by using the following:
|
||||||
|
--
|
||||||
|
-- * A scalar is a paragraph.
|
||||||
|
-- * A sequence is an unordered list.
|
||||||
|
-- * A mapping is a definition list.
|
||||||
|
newtype Html = Html B.ByteString
|
||||||
|
|
||||||
|
instance FromObject Html where
|
||||||
|
fromObject o = return $ Html $ B.concat
|
||||||
|
[ toStrictByteString "<!DOCTYPE html>\n<html><body>"
|
||||||
|
, helper o
|
||||||
|
, toStrictByteString "</body></html>"
|
||||||
|
] where
|
||||||
|
helper :: Object -> B.ByteString
|
||||||
|
helper (Scalar s) = B.concat
|
||||||
|
[ toStrictByteString "<p>"
|
||||||
|
, s
|
||||||
|
, toStrictByteString "</p>"
|
||||||
|
]
|
||||||
|
helper (Sequence []) = toStrictByteString "<ul></ul>"
|
||||||
|
helper (Sequence s) = B.concat
|
||||||
|
[ toStrictByteString "<ul><li>"
|
||||||
|
, B.intercalate (toStrictByteString "</li><li>") $ map helper s
|
||||||
|
, toStrictByteString "</li></ul>"
|
||||||
|
]
|
||||||
|
helper (Mapping m) = B.concat $
|
||||||
|
toStrictByteString "<dl>" :
|
||||||
|
map helper2 m ++
|
||||||
|
[ toStrictByteString "</dl>" ]
|
||||||
|
helper2 :: (B.ByteString, Object) -> B.ByteString
|
||||||
|
helper2 (k, v) = B.concat $
|
||||||
|
[ toStrictByteString "<dt>"
|
||||||
|
, k
|
||||||
|
, toStrictByteString "</dt><dd>"
|
||||||
|
, helper v
|
||||||
|
, toStrictByteString "</dd>"
|
||||||
|
]
|
||||||
@ -1,27 +0,0 @@
|
|||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- Module : Web.Restful
|
|
||||||
-- Copyright : Michael Snoyman
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
||||||
-- Stability : Stable
|
|
||||||
-- Portability : portable
|
|
||||||
--
|
|
||||||
-- Lightweight framework for designing RESTful APIs.
|
|
||||||
--
|
|
||||||
---------------------------------------------------------
|
|
||||||
module Web.Restful
|
|
||||||
(
|
|
||||||
module Data.Object
|
|
||||||
, module Web.Restful.Request
|
|
||||||
, module Web.Restful.Response
|
|
||||||
, module Web.Restful.Application
|
|
||||||
, module Web.Restful.Definitions
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Object
|
|
||||||
import Web.Restful.Request
|
|
||||||
import Web.Restful.Response
|
|
||||||
import Web.Restful.Application
|
|
||||||
import Web.Restful.Definitions
|
|
||||||
@ -18,24 +18,14 @@ module Web.Restful.Application
|
|||||||
(
|
(
|
||||||
-- * Defining an application
|
-- * Defining an application
|
||||||
ApplicationMonad
|
ApplicationMonad
|
||||||
-- ** Routing
|
|
||||||
, addResource
|
|
||||||
-- ** Settings
|
-- ** Settings
|
||||||
, setHandler
|
|
||||||
, setRpxnowApiKey
|
|
||||||
, setResourceParser
|
|
||||||
, setHtmlWrapper
|
, setHtmlWrapper
|
||||||
-- ** Engage
|
-- ** Engage
|
||||||
, run
|
, toHackApp
|
||||||
-- * FIXME
|
|
||||||
, Application (..)
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- hideously long import list
|
-- hideously long import list
|
||||||
import qualified Hack
|
import qualified Hack
|
||||||
import qualified Hack.Handler.CGI
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import Control.Monad.Writer
|
|
||||||
import Control.Monad.State hiding (gets)
|
import Control.Monad.State hiding (gets)
|
||||||
import Web.Encodings
|
import Web.Encodings
|
||||||
import Data.Maybe (isJust)
|
import Data.Maybe (isJust)
|
||||||
@ -43,8 +33,7 @@ import Data.ByteString.Class
|
|||||||
import qualified Data.ByteString.Lazy as BS
|
import qualified Data.ByteString.Lazy as BS
|
||||||
import Data.Function.Predicate (equals)
|
import Data.Function.Predicate (equals)
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
import Control.Applicative ( Applicative (..))
|
||||||
import qualified Web.Authenticate.OpenId as OpenId
|
|
||||||
|
|
||||||
import Hack.Middleware.Gzip
|
import Hack.Middleware.Gzip
|
||||||
import Hack.Middleware.CleanPath
|
import Hack.Middleware.CleanPath
|
||||||
@ -52,19 +41,15 @@ import Hack.Middleware.Jsonp
|
|||||||
import Hack.Middleware.ClientSession
|
import Hack.Middleware.ClientSession
|
||||||
import Hack.Middleware.MethodOverride
|
import Hack.Middleware.MethodOverride
|
||||||
|
|
||||||
import Control.Applicative ((<$>), Applicative (..))
|
|
||||||
import Control.Arrow (second)
|
|
||||||
|
|
||||||
import Web.Restful.Request
|
import Web.Restful.Request
|
||||||
import Web.Restful.Response
|
import Web.Restful.Response
|
||||||
import Web.Restful.Constants
|
|
||||||
import Web.Restful.Utils
|
import Web.Restful.Utils
|
||||||
import Web.Restful.Handler
|
import Web.Restful.Handler
|
||||||
import Web.Restful.Definitions
|
import Web.Restful.Definitions
|
||||||
import Data.Object
|
import Web.Restful.Constants
|
||||||
|
|
||||||
-- | Contains settings and a list of resources.
|
-- | Contains settings and a list of resources.
|
||||||
type ApplicationMonad a = StateT (ApplicationSettings a) (Writer (HandlerMap a))
|
type ApplicationMonad a = State (ApplicationSettings a)
|
||||||
instance Applicative (ApplicationMonad a) where
|
instance Applicative (ApplicationMonad a) where
|
||||||
pure = return
|
pure = return
|
||||||
f <*> a = do
|
f <*> a = do
|
||||||
@ -72,20 +57,16 @@ instance Applicative (ApplicationMonad a) where
|
|||||||
a' <- a
|
a' <- a
|
||||||
return $! f' a'
|
return $! f' a'
|
||||||
data ApplicationSettings rn = ApplicationSettings
|
data ApplicationSettings rn = ApplicationSettings
|
||||||
{ hackHandler :: Hack.Application -> IO ()
|
{ encryptKey :: Either FilePath Word256
|
||||||
, rpxnowApiKey :: Maybe String
|
|
||||||
, encryptKey :: Either FilePath Word256
|
|
||||||
, appResourceParser :: ResourceParser rn
|
|
||||||
, hackMiddleware :: [Hack.Middleware]
|
, hackMiddleware :: [Hack.Middleware]
|
||||||
, response404 :: Hack.Env -> IO Hack.Response
|
, response404 :: Hack.Env -> IO Hack.Response
|
||||||
, htmlWrapper :: BS.ByteString -> BS.ByteString
|
, htmlWrapper :: BS.ByteString -> BS.ByteString
|
||||||
}
|
}
|
||||||
instance ResourceName a => Default (ApplicationSettings a) where
|
|
||||||
|
instance (HasResourceParser a) =>
|
||||||
|
Default (ApplicationSettings a) where
|
||||||
def = ApplicationSettings
|
def = ApplicationSettings
|
||||||
{ hackHandler = Hack.Handler.CGI.run
|
{ encryptKey = Left defaultKeyFile
|
||||||
, rpxnowApiKey = Nothing
|
|
||||||
, encryptKey = Left defaultKeyFile
|
|
||||||
, appResourceParser = \s -> ParsedResource (toResourceName s) []
|
|
||||||
, hackMiddleware =
|
, hackMiddleware =
|
||||||
[ gzip
|
[ gzip
|
||||||
, cleanPath
|
, cleanPath
|
||||||
@ -105,250 +86,65 @@ default404 env = return $
|
|||||||
|
|
||||||
-- FIXME document below here
|
-- FIXME document below here
|
||||||
|
|
||||||
addResource :: (Request req, Response res, ResourceName rn)
|
|
||||||
=> Verb
|
|
||||||
-> rn
|
|
||||||
-> (req -> IO res)
|
|
||||||
-> ApplicationMonad rn ()
|
|
||||||
addResource verb resourceName' f = do
|
|
||||||
let handler :: Handler
|
|
||||||
handler = Handler $ (fmap ResponseWrapper) . f
|
|
||||||
handlerDesc = HandlerDesc resourceName' verb handler
|
|
||||||
tell [handlerDesc]
|
|
||||||
|
|
||||||
setResourceParser :: ResourceName rn
|
|
||||||
=> ResourceParser rn
|
|
||||||
-> ApplicationMonad rn ()
|
|
||||||
setResourceParser newRP = do
|
|
||||||
s <- get
|
|
||||||
put $ s { appResourceParser = newRP }
|
|
||||||
|
|
||||||
setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad a ()
|
setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad a ()
|
||||||
setHtmlWrapper f = do
|
setHtmlWrapper f = do
|
||||||
s <- get
|
s <- get
|
||||||
put $ s { htmlWrapper = f }
|
put $ s { htmlWrapper = f }
|
||||||
|
|
||||||
run :: ResourceName a => ApplicationMonad a () -> IO ()
|
toHackApp :: (Eq a, HasResourceParser a, HasHandlers a b)
|
||||||
run m = do
|
=> ApplicationMonad a ()
|
||||||
let (settings, resources') = runWriter $ execStateT m def
|
-> b
|
||||||
|
-> IO Hack.Application
|
||||||
|
toHackApp am model = do
|
||||||
|
let settings = execState am def
|
||||||
key <- case encryptKey settings of
|
key <- case encryptKey settings of
|
||||||
Left f -> getKey f
|
Left f -> getKey f
|
||||||
Right k -> return k
|
Right k -> return k
|
||||||
let defApp = defaultResources settings
|
let handlers = getHandler model
|
||||||
defResources = execWriter $ execStateT defApp def
|
app' = toHackApplication handlers settings
|
||||||
resources = resources' ++ defResources -- FIXME rename HandlerDescs
|
clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way...
|
||||||
app' :: Hack.Application
|
|
||||||
app' = toHackApplication $ Application resources settings
|
|
||||||
clientsession' :: Hack.Middleware
|
|
||||||
clientsession' = clientsession [authCookieName] key
|
|
||||||
app :: Hack.Application
|
|
||||||
app = foldr ($) app' $ hackMiddleware settings ++ [clientsession']
|
app = foldr ($) app' $ hackMiddleware settings ++ [clientsession']
|
||||||
hackHandler settings app
|
return app
|
||||||
|
|
||||||
setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad a ()
|
toHackApplication :: (HasResourceParser resourceName, Eq resourceName)
|
||||||
setHandler h = do
|
=> HandlerMap resourceName
|
||||||
settings <- get
|
-> ApplicationSettings resourceName
|
||||||
put $ settings { hackHandler = h }
|
|
||||||
|
|
||||||
setRpxnowApiKey :: String -> ApplicationMonad a ()
|
|
||||||
setRpxnowApiKey k = do
|
|
||||||
settings <- get
|
|
||||||
put $ settings { rpxnowApiKey = Just k }
|
|
||||||
|
|
||||||
defaultResources :: ResourceName rn
|
|
||||||
=> ApplicationSettings rn
|
|
||||||
-> ApplicationMonad rn ()
|
|
||||||
defaultResources settings = do
|
|
||||||
addResource Get (toResourceName ["auth", "check"]) authCheck
|
|
||||||
addResource Get (toResourceName ["auth", "logout"]) authLogout
|
|
||||||
addResource Get (toResourceName ["auth", "openid"]) authOpenidForm
|
|
||||||
addResource Get (toResourceName ["auth", "openid", "forward"]) authOpenidForward
|
|
||||||
addResource Get (toResourceName ["auth", "openid", "complete"]) authOpenidComplete
|
|
||||||
case rpxnowApiKey settings of
|
|
||||||
Nothing -> return ()
|
|
||||||
Just key -> do
|
|
||||||
addResource Get (toResourceName ["auth", "login", "rpxnow"]) $
|
|
||||||
rpxnowLogin key
|
|
||||||
|
|
||||||
data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
|
|
||||||
instance Request OIDFormReq where
|
|
||||||
parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest"
|
|
||||||
instance Show OIDFormReq where
|
|
||||||
show (OIDFormReq Nothing _) = ""
|
|
||||||
show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
|
|
||||||
"</p>"
|
|
||||||
data OIDFormRes = OIDFormRes String (Maybe String)
|
|
||||||
instance Response OIDFormRes where
|
|
||||||
reps (OIDFormRes s dest) = [("text/html", response 200 heads s)]
|
|
||||||
where
|
|
||||||
heads =
|
|
||||||
case dest of
|
|
||||||
Nothing -> []
|
|
||||||
Just dest' ->
|
|
||||||
[("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")]
|
|
||||||
authOpenidForm :: OIDFormReq -> IO OIDFormRes
|
|
||||||
authOpenidForm m@(OIDFormReq _ dest) =
|
|
||||||
let html =
|
|
||||||
show m ++
|
|
||||||
"<form method='get' action='forward/'>" ++
|
|
||||||
"OpenID: <input type='text' name='openid'>" ++
|
|
||||||
"<input type='submit' value='Login'>" ++
|
|
||||||
"</form>"
|
|
||||||
in return $! OIDFormRes html dest
|
|
||||||
data OIDFReq = OIDFReq String String
|
|
||||||
instance Request OIDFReq where
|
|
||||||
parseRequest = do
|
|
||||||
oid <- getParam "openid"
|
|
||||||
env <- parseEnv
|
|
||||||
let complete = "http://" ++ Hack.serverName env ++ ":" ++
|
|
||||||
show (Hack.serverPort env) ++
|
|
||||||
"/auth/openid/complete/"
|
|
||||||
return $! OIDFReq oid complete
|
|
||||||
authOpenidForward :: OIDFReq -> IO GenResponse
|
|
||||||
authOpenidForward (OIDFReq oid complete) = do
|
|
||||||
res <- OpenId.getForwardUrl oid complete :: IO (Either String String)
|
|
||||||
return $
|
|
||||||
case res of
|
|
||||||
Left err -> RedirectResponse $ "/auth/openid/?message=" ++
|
|
||||||
encodeUrl err
|
|
||||||
Right url -> RedirectResponse url
|
|
||||||
|
|
||||||
data OIDComp = OIDComp [(String, String)] (Maybe String)
|
|
||||||
instance Request OIDComp where
|
|
||||||
parseRequest = do
|
|
||||||
rr <- ask
|
|
||||||
let gets = rawGetParams rr
|
|
||||||
dest <- cookieParam "DEST"
|
|
||||||
return $! OIDComp gets dest
|
|
||||||
data OIDCompRes = OIDCompResErr String
|
|
||||||
| OIDCompResGood String (Maybe String)
|
|
||||||
instance Response OIDCompRes where
|
|
||||||
reps (OIDCompResErr err) =
|
|
||||||
reps $ RedirectResponse
|
|
||||||
$ "/auth/openid/?message=" ++
|
|
||||||
encodeUrl err
|
|
||||||
reps (OIDCompResGood ident Nothing) =
|
|
||||||
reps $ OIDCompResGood ident (Just "/")
|
|
||||||
reps (OIDCompResGood ident (Just dest)) =
|
|
||||||
[("text/plain", response 303 heads "")] where
|
|
||||||
heads =
|
|
||||||
[ (authCookieName, ident)
|
|
||||||
, resetCookie "DEST"
|
|
||||||
, ("Location", dest)
|
|
||||||
]
|
|
||||||
|
|
||||||
resetCookie :: String -> (String, String)
|
|
||||||
resetCookie name =
|
|
||||||
("Set-Cookie",
|
|
||||||
name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
|
|
||||||
|
|
||||||
authOpenidComplete :: OIDComp -> IO OIDCompRes
|
|
||||||
authOpenidComplete (OIDComp gets' dest) = do
|
|
||||||
res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier)
|
|
||||||
return $
|
|
||||||
case res of
|
|
||||||
Left err -> OIDCompResErr err
|
|
||||||
Right (OpenId.Identifier ident) -> OIDCompResGood ident dest
|
|
||||||
|
|
||||||
-- | token dest
|
|
||||||
data RpxnowRequest = RpxnowRequest String (Maybe String)
|
|
||||||
instance Request RpxnowRequest where
|
|
||||||
parseRequest = do
|
|
||||||
token <- getParam "token"
|
|
||||||
dest <- getParam "dest"
|
|
||||||
return $! RpxnowRequest token $ chopHash `fmap` dest
|
|
||||||
|
|
||||||
chopHash :: String -> String
|
|
||||||
chopHash ('#':rest) = rest
|
|
||||||
chopHash x = x
|
|
||||||
|
|
||||||
-- | dest identifier
|
|
||||||
data RpxnowResponse = RpxnowResponse String (Maybe String)
|
|
||||||
instance Response RpxnowResponse where
|
|
||||||
reps (RpxnowResponse dest Nothing) =
|
|
||||||
[("text/html", response 303 [("Location", dest)] "")]
|
|
||||||
reps (RpxnowResponse dest (Just ident)) =
|
|
||||||
[("text/html", response 303
|
|
||||||
[ ("Location", dest)
|
|
||||||
, (authCookieName, ident)
|
|
||||||
]
|
|
||||||
"")]
|
|
||||||
|
|
||||||
rpxnowLogin :: String -- ^ api key
|
|
||||||
-> RpxnowRequest
|
|
||||||
-> IO RpxnowResponse
|
|
||||||
rpxnowLogin apiKey (RpxnowRequest token dest') = do
|
|
||||||
let dest = case dest' of
|
|
||||||
Nothing -> "/"
|
|
||||||
Just "" -> "/"
|
|
||||||
Just s -> s
|
|
||||||
ident' <- Rpxnow.authenticate apiKey token
|
|
||||||
return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident')
|
|
||||||
|
|
||||||
data AuthRequest = AuthRequest (Maybe String)
|
|
||||||
instance Request AuthRequest where
|
|
||||||
parseRequest = AuthRequest `fmap` identifier
|
|
||||||
|
|
||||||
authCheck :: AuthRequest -> IO Object
|
|
||||||
authCheck (AuthRequest Nothing) =
|
|
||||||
return $ toObject [("status", "notloggedin")]
|
|
||||||
authCheck (AuthRequest (Just i)) =
|
|
||||||
return $ toObject
|
|
||||||
[ ("status", "loggedin")
|
|
||||||
, ("ident", i)
|
|
||||||
]
|
|
||||||
|
|
||||||
authLogout :: () -> IO LogoutResponse
|
|
||||||
authLogout _ = return LogoutResponse
|
|
||||||
|
|
||||||
data LogoutResponse = LogoutResponse
|
|
||||||
instance Response LogoutResponse where
|
|
||||||
reps _ = map (second addCookie) $ reps tree where
|
|
||||||
tree = toObject [("status", "loggedout")]
|
|
||||||
addCookie (Hack.Response s h c) =
|
|
||||||
Hack.Response s (h':h) c
|
|
||||||
h' = resetCookie authCookieName
|
|
||||||
|
|
||||||
toHackApplication :: Eq resourceName
|
|
||||||
=> Application resourceName
|
|
||||||
-> Hack.Application
|
-> Hack.Application
|
||||||
toHackApplication (Application hm settings) env = do
|
toHackApplication hm settings env = do
|
||||||
let (Right resource) = splitPath $ Hack.pathInfo env
|
let (Right resource) = splitPath $ Hack.pathInfo env
|
||||||
(ParsedResource rn urlParams') = (appResourceParser settings) resource
|
case resourceParser resource of
|
||||||
verb :: Verb
|
Nothing -> response404 settings $ env
|
||||||
verb = toVerb $ Hack.requestMethod env
|
(Just (ParsedResource rn urlParams')) -> do
|
||||||
rr :: RawRequest
|
let verb :: Verb
|
||||||
rr = envToRawRequest urlParams' env
|
verb = toVerb $ Hack.requestMethod env
|
||||||
matchingHandler (HandlerDesc resourceName' verb' _) =
|
rr :: RawRequest
|
||||||
rn == resourceName' &&
|
rr = envToRawRequest urlParams' env
|
||||||
verb == verb'
|
case hm rn verb of
|
||||||
case filter matchingHandler hm of
|
(Just handler) -> do
|
||||||
[HandlerDesc _ _ handler] -> do
|
let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
|
||||||
let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
|
ctypes' = parseHttpAccept rawHttpAccept
|
||||||
ctypes' = parseHttpAccept rawHttpAccept
|
body <- runHandler handler rr
|
||||||
body <- runHandler handler rr
|
let reps' = reps body
|
||||||
let reps' = reps body
|
ctypes = filter (\c -> isJust $ lookup c reps') ctypes'
|
||||||
ctypes = filter (\c -> isJust $ lookup c reps') ctypes'
|
let handlerPair =
|
||||||
let handlerPair =
|
case ctypes of
|
||||||
case ctypes of
|
[] -> Just $ head reps'
|
||||||
[] -> Just $ head reps'
|
(c:_) ->
|
||||||
(c:_) ->
|
case filter (fst `equals` c) reps' of
|
||||||
case filter (fst `equals` c) reps' of
|
[pair] -> Just pair
|
||||||
[pair] -> Just pair
|
[] -> Nothing
|
||||||
[] -> Nothing
|
_ -> error "Overlapping reps"
|
||||||
_ -> error "Overlapping reps"
|
case handlerPair of
|
||||||
case handlerPair of
|
Nothing -> response404 settings $ env
|
||||||
Nothing -> response404 settings $ env
|
Just (ctype, Hack.Response status headers content) -> do
|
||||||
Just (ctype, Hack.Response status headers content) -> do
|
let wrapper =
|
||||||
let wrapper =
|
case ctype of
|
||||||
case ctype of
|
"text/html" -> htmlWrapper settings
|
||||||
"text/html" -> htmlWrapper settings
|
_ -> id
|
||||||
_ -> id
|
return $ Hack.Response status
|
||||||
return $ Hack.Response status
|
(("Content-Type", ctype) : headers)
|
||||||
(("Content-Type", ctype) : headers)
|
$ toLazyByteString $ wrapper content
|
||||||
$ toLazyByteString $ wrapper content
|
Nothing -> response404 settings $ env
|
||||||
[] -> response404 settings $ env
|
|
||||||
_ -> fail $ "Overlapping handlers for: " ++ show env
|
|
||||||
|
|
||||||
envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
|
envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
|
||||||
envToRawRequest urlParams' env =
|
envToRawRequest urlParams' env =
|
||||||
@ -361,8 +157,3 @@ envToRawRequest urlParams' env =
|
|||||||
rawCookie = tryLookup "" "Cookie" $ Hack.http env
|
rawCookie = tryLookup "" "Cookie" $ Hack.http env
|
||||||
cookies' = decodeCookies rawCookie :: [(String, String)]
|
cookies' = decodeCookies rawCookie :: [(String, String)]
|
||||||
in RawRequest rawPieces urlParams' gets' posts cookies' files env
|
in RawRequest rawPieces urlParams' gets' posts cookies' files env
|
||||||
|
|
||||||
data Application a = Application
|
|
||||||
{ handlerMap :: HandlerMap a
|
|
||||||
, applicationSettings :: ApplicationSettings a
|
|
||||||
}
|
|
||||||
|
|||||||
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
--
|
--
|
||||||
-- Module : Web.Restful.Definitions
|
-- Module : Web.Restful.Definitions
|
||||||
@ -18,7 +19,7 @@ module Web.Restful.Definitions
|
|||||||
, Resource
|
, Resource
|
||||||
, ParsedResource (..)
|
, ParsedResource (..)
|
||||||
, ResourceParser
|
, ResourceParser
|
||||||
, ResourceName (..)
|
, HasResourceParser (..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Hack
|
import qualified Hack
|
||||||
@ -34,14 +35,14 @@ toVerb _ = Get
|
|||||||
|
|
||||||
type Resource = [String]
|
type Resource = [String]
|
||||||
|
|
||||||
class Eq a => ResourceName a where
|
|
||||||
toResourceName :: [String] -> a
|
|
||||||
instance ResourceName [String] where
|
|
||||||
toResourceName = id
|
|
||||||
|
|
||||||
data ParsedResource a = ParsedResource
|
data ParsedResource a = ParsedResource
|
||||||
{ resourceName :: a
|
{ resourceName :: a
|
||||||
, urlParameters :: [(String, String)]
|
, urlParameters :: [(String, String)]
|
||||||
}
|
}
|
||||||
|
|
||||||
type ResourceParser a = Resource -> ParsedResource a
|
type ResourceParser a = Resource -> Maybe (ParsedResource a)
|
||||||
|
|
||||||
|
class HasResourceParser a where
|
||||||
|
resourceParser :: ResourceParser a
|
||||||
|
simpleParse :: a -> Maybe (ParsedResource a)
|
||||||
|
simpleParse x = Just $ ParsedResource x []
|
||||||
|
|||||||
@ -1,4 +1,6 @@
|
|||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
--
|
--
|
||||||
-- Module : Web.Restful.Handler
|
-- Module : Web.Restful.Handler
|
||||||
@ -16,7 +18,8 @@ module Web.Restful.Handler
|
|||||||
( Handler (..)
|
( Handler (..)
|
||||||
, runHandler
|
, runHandler
|
||||||
, HandlerMap
|
, HandlerMap
|
||||||
, HandlerDesc (..)
|
, HasHandlers (..)
|
||||||
|
, liftHandler
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Web.Restful.Definitions
|
import Web.Restful.Definitions
|
||||||
@ -32,5 +35,12 @@ runHandler (Handler f) rreq = do
|
|||||||
Left errors -> fail $ unlines errors -- FIXME
|
Left errors -> fail $ unlines errors -- FIXME
|
||||||
Right req -> f req
|
Right req -> f req
|
||||||
|
|
||||||
data HandlerDesc a = HandlerDesc a Verb Handler
|
type HandlerMap a = a -> Verb -> Maybe Handler
|
||||||
type HandlerMap a = [HandlerDesc a]
|
|
||||||
|
class HasHandlers a b | a -> b where
|
||||||
|
getHandler :: b -> a -> Verb -> Maybe Handler
|
||||||
|
|
||||||
|
liftHandler :: (Request req, Response res)
|
||||||
|
=> (req -> IO res)
|
||||||
|
-> Maybe Handler
|
||||||
|
liftHandler f = Just . Handler $ fmap ResponseWrapper . f
|
||||||
|
|||||||
216
Web/Restful/Helpers/Auth.hs
Normal file
216
Web/Restful/Helpers/Auth.hs
Normal file
@ -0,0 +1,216 @@
|
|||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
---------------------------------------------------------
|
||||||
|
--
|
||||||
|
-- Module : Web.Restful.Helpers.Auth
|
||||||
|
-- Copyright : Michael Snoyman
|
||||||
|
-- License : BSD3
|
||||||
|
--
|
||||||
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||||
|
-- Stability : Stable
|
||||||
|
-- Portability : portable
|
||||||
|
--
|
||||||
|
-- Authentication through the authentication package.
|
||||||
|
--
|
||||||
|
---------------------------------------------------------
|
||||||
|
module Web.Restful.Helpers.Auth
|
||||||
|
( AuthResource
|
||||||
|
, FromAuthResource (..)
|
||||||
|
, authResourceParser
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified Hack
|
||||||
|
import Web.Encodings
|
||||||
|
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||||
|
import qualified Web.Authenticate.OpenId as OpenId
|
||||||
|
|
||||||
|
import Web.Restful
|
||||||
|
import Web.Restful.Constants
|
||||||
|
|
||||||
|
import Control.Applicative ((<$>), Applicative (..))
|
||||||
|
import Control.Arrow (second)
|
||||||
|
import Control.Monad.Reader
|
||||||
|
|
||||||
|
import Data.Object
|
||||||
|
|
||||||
|
data AuthResource =
|
||||||
|
AuthCheck
|
||||||
|
| AuthLogout
|
||||||
|
| AuthOpenid
|
||||||
|
| AuthOpenidForward
|
||||||
|
| AuthOpenidComplete
|
||||||
|
| AuthLoginRpxnow
|
||||||
|
deriving Eq
|
||||||
|
class FromAuthResource a where
|
||||||
|
fromAuthResource :: AuthResource -> a
|
||||||
|
|
||||||
|
authResourceParser :: FromAuthResource far
|
||||||
|
=> Resource
|
||||||
|
-> Maybe (ParsedResource far)
|
||||||
|
authResourceParser ["check"] =
|
||||||
|
authResourceParser' AuthCheck
|
||||||
|
authResourceParser ["logout"] =
|
||||||
|
authResourceParser' AuthLogout
|
||||||
|
authResourceParser ["openid"] =
|
||||||
|
authResourceParser' AuthOpenid
|
||||||
|
authResourceParser ["openid", "forward"] =
|
||||||
|
authResourceParser' AuthOpenidForward
|
||||||
|
authResourceParser ["openid", "complete"] =
|
||||||
|
authResourceParser' AuthOpenidComplete
|
||||||
|
authResourceParser ["login", "rpxnow"] =
|
||||||
|
authResourceParser' AuthLoginRpxnow
|
||||||
|
authResourceParser _ = Nothing
|
||||||
|
|
||||||
|
authResourceParser' :: FromAuthResource far
|
||||||
|
=> AuthResource
|
||||||
|
-> Maybe (ParsedResource far)
|
||||||
|
authResourceParser' x = Just $ ParsedResource (fromAuthResource x) []
|
||||||
|
|
||||||
|
type RpxnowApiKey = String -- FIXME newtype
|
||||||
|
instance HasHandlers AuthResource (Maybe RpxnowApiKey) where
|
||||||
|
getHandler _ AuthCheck Get = liftHandler authCheck
|
||||||
|
getHandler _ AuthLogout Get = liftHandler authLogout
|
||||||
|
getHandler _ AuthOpenid Get = liftHandler authOpenidForm
|
||||||
|
getHandler _ AuthOpenidForward Get = liftHandler authOpenidForward
|
||||||
|
getHandler _ AuthOpenidComplete Get = liftHandler authOpenidComplete
|
||||||
|
getHandler (Just key) AuthLoginRpxnow Get = liftHandler $ rpxnowLogin key
|
||||||
|
getHandler _ _ _ = Nothing
|
||||||
|
|
||||||
|
data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
|
||||||
|
instance Request OIDFormReq where
|
||||||
|
parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest"
|
||||||
|
instance Show OIDFormReq where
|
||||||
|
show (OIDFormReq Nothing _) = ""
|
||||||
|
show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
|
||||||
|
"</p>"
|
||||||
|
data OIDFormRes = OIDFormRes String (Maybe String)
|
||||||
|
instance Response OIDFormRes where
|
||||||
|
reps (OIDFormRes s dest) = [("text/html", response 200 heads s)]
|
||||||
|
where
|
||||||
|
heads =
|
||||||
|
case dest of
|
||||||
|
Nothing -> []
|
||||||
|
Just dest' ->
|
||||||
|
[("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")]
|
||||||
|
authOpenidForm :: OIDFormReq -> IO OIDFormRes
|
||||||
|
authOpenidForm m@(OIDFormReq _ dest) =
|
||||||
|
let html =
|
||||||
|
show m ++
|
||||||
|
"<form method='get' action='forward/'>" ++
|
||||||
|
"OpenID: <input type='text' name='openid'>" ++
|
||||||
|
"<input type='submit' value='Login'>" ++
|
||||||
|
"</form>"
|
||||||
|
in return $! OIDFormRes html dest
|
||||||
|
data OIDFReq = OIDFReq String String
|
||||||
|
instance Request OIDFReq where
|
||||||
|
parseRequest = do
|
||||||
|
oid <- getParam "openid"
|
||||||
|
env <- parseEnv
|
||||||
|
let complete = "http://" ++ Hack.serverName env ++ ":" ++
|
||||||
|
show (Hack.serverPort env) ++
|
||||||
|
"/auth/openid/complete/"
|
||||||
|
return $! OIDFReq oid complete
|
||||||
|
authOpenidForward :: OIDFReq -> IO GenResponse
|
||||||
|
authOpenidForward (OIDFReq oid complete) = do
|
||||||
|
res <- OpenId.getForwardUrl oid complete :: IO (Either String String)
|
||||||
|
return $
|
||||||
|
case res of
|
||||||
|
Left err -> RedirectResponse $ "/auth/openid/?message=" ++
|
||||||
|
encodeUrl err
|
||||||
|
Right url -> RedirectResponse url
|
||||||
|
|
||||||
|
data OIDComp = OIDComp [(String, String)] (Maybe String)
|
||||||
|
instance Request OIDComp where
|
||||||
|
parseRequest = do
|
||||||
|
rr <- ask
|
||||||
|
let gets = rawGetParams rr
|
||||||
|
dest <- cookieParam "DEST"
|
||||||
|
return $! OIDComp gets dest
|
||||||
|
data OIDCompRes = OIDCompResErr String
|
||||||
|
| OIDCompResGood String (Maybe String)
|
||||||
|
instance Response OIDCompRes where
|
||||||
|
reps (OIDCompResErr err) =
|
||||||
|
reps $ RedirectResponse
|
||||||
|
$ "/auth/openid/?message=" ++
|
||||||
|
encodeUrl err
|
||||||
|
reps (OIDCompResGood ident Nothing) =
|
||||||
|
reps $ OIDCompResGood ident (Just "/")
|
||||||
|
reps (OIDCompResGood ident (Just dest)) =
|
||||||
|
[("text/plain", response 303 heads "")] where
|
||||||
|
heads =
|
||||||
|
[ (authCookieName, ident)
|
||||||
|
, resetCookie "DEST"
|
||||||
|
, ("Location", dest)
|
||||||
|
]
|
||||||
|
|
||||||
|
resetCookie :: String -> (String, String)
|
||||||
|
resetCookie name =
|
||||||
|
("Set-Cookie",
|
||||||
|
name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
|
||||||
|
|
||||||
|
authOpenidComplete :: OIDComp -> IO OIDCompRes
|
||||||
|
authOpenidComplete (OIDComp gets' dest) = do
|
||||||
|
res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier)
|
||||||
|
return $
|
||||||
|
case res of
|
||||||
|
Left err -> OIDCompResErr err
|
||||||
|
Right (OpenId.Identifier ident) -> OIDCompResGood ident dest
|
||||||
|
|
||||||
|
-- | token dest
|
||||||
|
data RpxnowRequest = RpxnowRequest String (Maybe String)
|
||||||
|
instance Request RpxnowRequest where
|
||||||
|
parseRequest = do
|
||||||
|
token <- getParam "token"
|
||||||
|
dest <- getParam "dest"
|
||||||
|
return $! RpxnowRequest token $ chopHash `fmap` dest
|
||||||
|
|
||||||
|
chopHash :: String -> String
|
||||||
|
chopHash ('#':rest) = rest
|
||||||
|
chopHash x = x
|
||||||
|
|
||||||
|
-- | dest identifier
|
||||||
|
data RpxnowResponse = RpxnowResponse String (Maybe String)
|
||||||
|
instance Response RpxnowResponse where
|
||||||
|
reps (RpxnowResponse dest Nothing) =
|
||||||
|
[("text/html", response 303 [("Location", dest)] "")]
|
||||||
|
reps (RpxnowResponse dest (Just ident)) =
|
||||||
|
[("text/html", response 303
|
||||||
|
[ ("Location", dest)
|
||||||
|
, (authCookieName, ident)
|
||||||
|
]
|
||||||
|
"")]
|
||||||
|
|
||||||
|
rpxnowLogin :: String -- ^ api key
|
||||||
|
-> RpxnowRequest
|
||||||
|
-> IO RpxnowResponse
|
||||||
|
rpxnowLogin apiKey (RpxnowRequest token dest') = do
|
||||||
|
let dest = case dest' of
|
||||||
|
Nothing -> "/"
|
||||||
|
Just "" -> "/"
|
||||||
|
Just s -> s
|
||||||
|
ident' <- Rpxnow.authenticate apiKey token
|
||||||
|
return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident')
|
||||||
|
|
||||||
|
data AuthRequest = AuthRequest (Maybe String)
|
||||||
|
instance Request AuthRequest where
|
||||||
|
parseRequest = AuthRequest `fmap` identifier
|
||||||
|
|
||||||
|
authCheck :: AuthRequest -> IO Object
|
||||||
|
authCheck (AuthRequest Nothing) =
|
||||||
|
return $ toObject [("status", "notloggedin")]
|
||||||
|
authCheck (AuthRequest (Just i)) =
|
||||||
|
return $ toObject
|
||||||
|
[ ("status", "loggedin")
|
||||||
|
, ("ident", i)
|
||||||
|
]
|
||||||
|
|
||||||
|
authLogout :: () -> IO LogoutResponse
|
||||||
|
authLogout _ = return LogoutResponse
|
||||||
|
|
||||||
|
data LogoutResponse = LogoutResponse
|
||||||
|
instance Response LogoutResponse where
|
||||||
|
reps _ = map (second addCookie) $ reps tree where
|
||||||
|
tree = toObject [("status", "loggedout")]
|
||||||
|
addCookie (Hack.Response s h c) =
|
||||||
|
Hack.Response s (h':h) c
|
||||||
|
h' = resetCookie authCookieName
|
||||||
@ -47,6 +47,7 @@ import System.Locale
|
|||||||
import Web.Restful.Request -- FIXME ultimately remove
|
import Web.Restful.Request -- FIXME ultimately remove
|
||||||
import Data.Object
|
import Data.Object
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
|
import Data.Object.Instances
|
||||||
|
|
||||||
type ContentType = String
|
type ContentType = String
|
||||||
|
|
||||||
|
|||||||
@ -29,7 +29,8 @@ library
|
|||||||
bytestring-class,
|
bytestring-class,
|
||||||
web-encodings,
|
web-encodings,
|
||||||
mtl >= 1.1.0.2,
|
mtl >= 1.1.0.2,
|
||||||
data-object
|
data-object,
|
||||||
|
yaml >= 0.0.1
|
||||||
exposed-modules: Web.Restful,
|
exposed-modules: Web.Restful,
|
||||||
Web.Restful.Constants,
|
Web.Restful.Constants,
|
||||||
Web.Restful.Request,
|
Web.Restful.Request,
|
||||||
@ -37,5 +38,8 @@ library
|
|||||||
Web.Restful.Utils,
|
Web.Restful.Utils,
|
||||||
Web.Restful.Definitions,
|
Web.Restful.Definitions,
|
||||||
Web.Restful.Handler,
|
Web.Restful.Handler,
|
||||||
Web.Restful.Application
|
Web.Restful.Application,
|
||||||
|
Data.Object.Instances,
|
||||||
|
Hack.Middleware.MethodOverride,
|
||||||
|
Web.Restful.Helpers.Auth
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user