mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

import yesod qualified

Browse source 
To avoid conflict with different liftIO from MonadIO (in some version of
yesod not the one I have here), and because it's generally clearer, since
this module has both Wai and Yesod stuff, to qualify them both.
This commit is contained in:
Joey Hess 2012-08-30 13:05:39 -04:00
parent f68afa9cc1
commit faf3faa79d
1 changed files with 10 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

20
Utility/WebApp.hs
View file

@ -11,7 +11,7 @@ module Utility.WebApp where
import Common import Common
import Yesod import qualified Yesod
import qualified Network.Wai as Wai import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Network.Wai.Logger import Network.Wai.Logger
@ -55,7 +55,7 @@ runBrowser url = boolSystem cmd [Param url]
- An IO action can also be run, to do something with the port number, - An IO action can also be run, to do something with the port number,
- such as start a web browser to view the webapp. - such as start a web browser to view the webapp.
-} -}
runWebApp :: Application -> (PortNumber -> IO ()) -> IO () runWebApp :: Wai.Application -> (PortNumber -> IO ()) -> IO ()
runWebApp app observer = do runWebApp app observer = do
sock <- localSocket sock <- localSocket
void $ forkIO $ runSettingsSocket defaultSettings sock app void $ forkIO $ runSettingsSocket defaultSettings sock app
@ -119,7 +119,7 @@ lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
{- Rather than storing a session key on disk, use a random key {- Rather than storing a session key on disk, use a random key
- that will only be valid for this run of the webapp. -} - that will only be valid for this run of the webapp. -}
webAppSessionBackend :: Yesod y => y -> IO (Maybe (SessionBackend y)) webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe (Yesod.SessionBackend y))
webAppSessionBackend _ = do webAppSessionBackend _ = do
g <- newGenIO :: IO SystemRandom g <- newGenIO :: IO SystemRandom
case genBytes 96 g of case genBytes 96 g of
@ -127,7 +127,7 @@ webAppSessionBackend _ = do
Right (s, _) -> case CS.initKey s of Right (s, _) -> case CS.initKey s of
Left e -> error $ "failed to initialize key: " ++ show e Left e -> error $ "failed to initialize key: " ++ show e
Right key -> return $ Just $ Right key -> return $ Just $
clientSessionBackend key 120 Yesod.clientSessionBackend key 120
{- Generates a random sha512 string, suitable to be used for an {- Generates a random sha512 string, suitable to be used for an
- authentication secret. -} - authentication secret. -}
@ -145,14 +145,14 @@ genRandomToken = do
- Note that the usual Yesod error page is bypassed on error, to avoid - Note that the usual Yesod error page is bypassed on error, to avoid
- possibly leaking the auth token in urls on that page! - possibly leaking the auth token in urls on that page!
-} -}
checkAuthToken :: forall t sub. (t -> T.Text) -> GHandler sub t AuthResult checkAuthToken :: forall t sub. (t -> T.Text) -> Yesod.GHandler sub t Yesod.AuthResult
checkAuthToken extractToken = do checkAuthToken extractToken = do
webapp <- getYesod webapp <- Yesod.getYesod
req <- getRequest req <- Yesod.getRequest
let params = reqGetParams req let params = Yesod.reqGetParams req
if lookup "auth" params == Just (extractToken webapp) if lookup "auth" params == Just (extractToken webapp)
then return Authorized then return Yesod.Authorized
else sendResponseStatus unauthorized401 () else Yesod.sendResponseStatus unauthorized401 ()
{- A Yesod joinPath method, which adds an auth cgi parameter to every {- A Yesod joinPath method, which adds an auth cgi parameter to every
- url matching a predicate, containing a token extracted from the - url matching a predicate, containing a token extracted from the