diff --git a/happs-tutorial.cabal b/happs-tutorial.cabal --- a/happs-tutorial.cabal +++ b/happs-tutorial.cabal @@ -1,5 +1,5 @@ Name: happs-tutorial -Version: 0.9.3 +Version: 0.9.4 Synopsis: A Happstack Tutorial that is its own web 2.0-type demo. Description: A nice way to learn how to build web sites with Happstack @@ -48,26 +48,27 @@ View ghc-options: -Wall Build-Depends: base - , HStringTemplate >= 0.4.0 && < 0.5.0 + -- , HStringTemplate >= 0.4.0 && < 0.5.0 + , HStringTemplate >= 0.6 , HStringTemplateHelpers >= 0.0.14 && < 1.0.0 , mtl >= 1.1.0.0 && < 2.0.0.0 - , bytestring >= 0.9.0.0 && < 0.10.0.0 - , happstack >= 0.3 && < 0.5 + , bytestring + , happstack >= 0.5 , containers >= 0.2.0.0 && < 0.3.0.0 , pretty >= 1.0.1.0 && < 2 , pureMD5 >= 1.0.0.0 && < 1.1.0.0 , directory >= 1.0.0.0 && < 1.1.0.0 , filepath >= 1.1.0.0 && < 1.2.0.0 , hscolour == 1.13 - , HTTP >= 4000.0.7 && < 4000.0.8 + , HTTP >= 4000 , safe >= 0.2 && < 0.3 , old-time >= 1.0.0.0 && < 1.1.0.0 , parsec >= 2.1.0.0 && < 2.2.0.0 - , happstack-helpers >= 0.43 && < 0.50 + , happstack-helpers >= 0.50 , DebugTraceHelpers >= 0.12 && < 0.20 - , happstack-server >= 0.3 && < 0.5 - , happstack-data >= 0.3 && < 0.5 - , happstack-ixset >= 0.3 && < 0.5 - , happstack-state >= 0.3 && < 0.5 + , happstack-server >= 0.5 + , happstack-data >= 0.5 + , happstack-ixset >= 0.5 + , happstack-state >= 0.5 if flag(base4) Build-Depends: base >=4 && <5, syb diff --git a/src/ControllerPostActions.hs b/src/ControllerPostActions.hs --- a/src/ControllerPostActions.hs +++ b/src/ControllerPostActions.hs @@ -19,31 +19,32 @@ loginPage :: RenderGlobals -> ServerPartT IO Response -loginPage rglobs@(RenderGlobals rq _ _) = - -- unfortunately can't just use rqUrl rq here, because sometimes has port numbers and... it gets complicated - case tutAppReferrer rq of - Left e -> return $ errW rglobs e - Right landingpage -> loginPage' authUser (const startsess') rglobs landingpage +loginPage rglobs = do + ref <- runErrorT tutAppReferrer + let landingpage = fromEither "/" $ ref -- tutAppReferrer rq + loginPage' authUser (const startsess') rglobs landingpage where authUser = authUser' getUserPassword getUserPassword name = return . maybe Nothing (Just . B.unpack . password) =<< query (GetUserInfos name) +-- move to common code/helpers +fromEither :: a -> Either e a -> a +fromEither def (Left _) = def +fromEither _ (Right x) = x + -- move this to HAppSHelpers -tutAppReferrer :: Request -> Either String String -tutAppReferrer rq = do - let approot :: Either String String - approot = modRewriteAppUrl "" rq - case approot of - Left _ -> Left $ "tutAppReferrer, could not determine approot, rq: " ++ (show rq) - Right ar -> - case getHeaderVal "referer" rq of - Left e -> Left $ "smartAppReferrer error, rq: " ++ e - -- check against logout, otherwise if you have just logged out then - -- try immediately to log in again it won't let you. - Right rf -> if isInfixOf "logout" rf || isInfixOf "login" rf || isInfixOf "newuser" rf - then Right ar - else Right rf +--tutAppReferrer :: Request -> Either String String +tutAppReferrer :: ServerMonad m => ErrorT String m String +tutAppReferrer = do + -- check against logout, otherwise if you have just logged out then + -- try immediately to log in again it won't let you. (???) + rf <- ErrorT $ getHeaderVal "referer" `liftM` askRq + return $ if or $ map (flip isInfixOf rf) ["logout", "login", "newuser"] + then "/" + else rf +-- getReferrer = getHeaderVal "referer" =<< askRq + -- Use a helper function because the plan is to eventually have a similar function -- that works for admin logins loginPage' :: (Monad m) => @@ -127,14 +128,10 @@ newUserPage :: RenderGlobals -> ServerPartT IO Response newUserPage rglobs = do NewUserInfo user pass1 pass2 <- getData' - rq <- askRq etRes <- runErrorT $ setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) case etRes of Left err -> return $ errW rglobs err - Right () -> case modRewriteAppUrl "tutorial/registered" rq of - Left e -> return $ errW rglobs e - Right p -> startsess' user p - + Right () -> startsess' user "/tutorial/registered" where setupNewUser :: NewUserInfo -> ErrorT String (ServerPartT IO) () setupNewUser (NewUserInfo user pass1 pass2) = do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -17,6 +17,7 @@ let p = read port allowStressTests = read allowStressTests' dynamicTemplateReload = read dynamicTemplateReload' + --cleanUpLockFile "happs-tutorial" "tutorial.happstack.com" "happstack" 5 tDirGroups <- getTemplateGroups -- defined in Controller.hs {- smartserver and its cousin smartserver' are from the happstack-helpers package. They are essentially a combination startSystemState and simpleHTTP('), with a @@ -25,7 +26,7 @@ Just like with simpleHTTP we pass in the ServerPartT, given by controller from Controller.hs, and just like startSystemState we pass in a Proxy in order to initialize the system state. -} - smartserver (Conf p Nothing) "happs-tutorial" + smartserver (Conf p Nothing) (controller tDirGroups dynamicTemplateReload allowStressTests) stateProxy _ -> putStrLn "usage example: happs-tutorial 5001 True True (starts the app on port 5001, \ @@ -36,7 +37,7 @@ putStrLn $ "happs tutorial running in ghci. \n" ++ "exit :q ghci completely and reenter ghci, before restarting." tDirGroups <- getTemplateGroups - smartserver (Conf 5001 Nothing) "happs-tutorial" (controller tDirGroups True True) stateProxy + smartserver (Conf 5001 Nothing) (controller tDirGroups True True) stateProxy stateProxy :: Proxy AppState stateProxy = Proxy diff --git a/templates/footer.st b/templates/footer.st --- a/templates/footer.st +++ b/templates/footer.st @@ -1,7 +1,7 @@