diff --git a/Application.hs b/Application.hs index cc55a67..379bdc6 100644 --- a/Application.hs +++ b/Application.hs @@ -33,7 +33,7 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, import Handler.Common import Handler.Home import Handler.Wallet -import Handler.Register +import Handler.Settings -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/Foundation.hs b/Foundation.hs index 4c5edaa..4fba855 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -1,15 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + module Foundation where import Import.NoFoundation import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) -import Yesod.Auth.BrowserId (authBrowserId) +--import Yesod.Auth.BrowserId (authBrowserId) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe -import Yesod.Auth.HashDB (authHashDB) -import Yesod.Auth.OAuth2.EveOnline (oauth2EveImage,ImageType(..)) +--import Yesod.Auth.HashDB (authHashDB) +import Yesod.Auth.OAuth2.EveOnline (oauth2Eve,WidgetType(..)) +import Data.Time.Format (parseTimeM) -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -47,7 +50,7 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes - makeSessionBackend _ = fmap Just $ defaultClientSessionBackend + makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 -- timeout in minutes "config/client_session_key.aes" @@ -124,37 +127,45 @@ instance YesodAuth App where redirectToReferer _ = True --authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master) - authenticate creds = do + authenticate creds = runDB $ do x <- getBy $ UniqueUser $ credsIdent creds now <- liftIO getCurrentTime + -- extra is charName tokenType and expires + liftIO $ print extra case x of Just (Entity uid _) -> do update uid [UserLastLogin =. now] return $ Authenticated uid - Nothing -> Authenticated <$> insert User - { userIdent = credsIdent creds - , userPassword = Nothing - , userLastLogin = now - } - -- return $ UserError Msg.InvalidLogin - {-getAuthId creds = do - auth <- authenticate creds - return $ case auth of - Authentication auid -> Just auid - _ -> Nothing-} - --getAuthIdHashDB AuthR (Just . UniqueUser) creds --authenticate on own site - {-do - runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (Entity uid _) -> return $ Just uid - Nothing -> return Nothing-} + Nothing -> case fromExtra of + Just (expiry,token,name,cid) -> Authenticated <$> insert User + { userIdent = credsIdent creds + , userName = name + , userCharId = cid + , userPassword = Nothing + , userLastLogin = now + , userTokenExpires = expiry + , userAccessToken = token + } + Nothing -> return $ ServerError "Problems extracting Access-Token" + where + extra = credsExtra creds + fromExtra = do + expires <- getFromExtra "expires" extra + token <- getFromExtra "accessToken" extra + name <- getFromExtra "charName" extra + cid <- getFromExtra "charId" extra >>= readMay + expiry <- parseTimeM True defaultTimeLocale "%FT%X" (unpack expires) :: Maybe UTCTime + -- %F = YYYY-MM-DD + -- %X = HH-MM-SS + return (expiry,token,name,cid) + getFromExtra :: Text -> [(Text,Text)] -> Maybe Text + getFromExtra s = fmap snd . listToMaybe . filter ((==) s . fst) -- You can add other plugins like BrowserID, email or OAuth here - authPlugins _ = [ authBrowserId def - , authHashDB (Just . UniqueUser) - , oauth2EveImage "" "" BigBlack + authPlugins _ = [ --authBrowserId def + --, authHashDB (Just . UniqueUser) + oauth2Eve "346ee0ad8f974e30be6bf422f40d891b" "kXnZd7f3pmRCvePiBPQcTL2aRcgBHSgPRxc6VNYT" BigBlack ] authHttpManager = getHttpManager diff --git a/Handler/Home.hs b/Handler/Home.hs index 130419a..8454e94 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -12,23 +12,29 @@ import Import getHomeR :: Handler Html getHomeR = do maid <- maybeAuthId + muser <- case maid of + Just uid -> runDB $ get uid + Nothing -> return $ Nothing defaultLayout $ do setTitle "NEAT" [whamlet|

- Welcome to NEAT. -
- Current Auth-ID: #{show maid}. + $maybe u <- muser + Welcome back #{userName u} + $nothing + Welcome to NEAT.
$maybe u <- maid

Data: #{show u}
Logout +
+ Wallet +
+ Settings $nothing

Login -

- Register Account |] {- (formWidget, formEnctype) <- generateFormPost sampleForm diff --git a/Handler/Register.hs b/Handler/Register.hs deleted file mode 100644 index c27c988..0000000 --- a/Handler/Register.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Handler.Register where - -import Import -import Yesod.Form.Bootstrap3 -import Yesod.Auth.HashDB (setPassword) -import Handler.Home (getHomeR) - -getRegisterR :: Handler Html -getRegisterR = do - (registerWidget, registerEnctype) <- generateFormPost registerForm - defaultLayout $ do - setTitle "Register" - [whamlet| -

Register -
- ^{registerWidget} - |] - -postRegisterR :: Handler Html -postRegisterR = do - ((result,registerWidget), registerEnctype) <- runFormPost registerForm - let again err = defaultLayout $ do - setTitle "Register" - [whamlet| -
Error: #{err} -

Register - - ^{registerWidget} - |] - case result of - FormSuccess (user,mail) -> do - u <- liftIO $ setPassword (fromMaybe "" $ userPassword user) user - _ <- runDB $ do - uid <- insert u - insert $ Email mail uid Nothing - getHomeR - FormFailure (err:_) -> again err - _ -> again "Invalid input" - - -registerForm :: Html -> MForm Handler (FormResult (User,Text), Widget) -registerForm extra = do - (nameRes, nameView) <- mreq textField ((withAutofocus . withPlaceholder "Username") (bfs ("Username" :: Text))) Nothing - (pwRes, pwView) <- mreq passwordField (bfs ("Password" :: Text)) Nothing - (pwcRes, pwcView) <- mreq passwordField (bfs ("Confirm password" :: Text)) Nothing - (emailRes, emailView) <- mreq emailField (withPlaceholder "User@mail" (bfs ("Email" :: Text))) Nothing - time <- lift $ liftIO getCurrentTime - let confirmRes = case pwRes of - FormSuccess x -> case pwcRes of - FormSuccess y -> if x == y then FormSuccess x else FormFailure ["Passwords did not match"] - a -> a - a -> a - let registerRes = (,) <$> (User <$> nameRes <*> (Just <$> confirmRes) <*> (FormSuccess time)) - <*> emailRes - let widget = [whamlet| - #{extra} -

- Username ^{fvInput nameView} -

- Password ^{fvInput pwView} -

- Confirm password ^{fvInput pwcView} -

- Email ^{fvInput emailView} - - |] - return (registerRes, widget) diff --git a/Handler/Settings.hs b/Handler/Settings.hs new file mode 100644 index 0000000..e377778 --- /dev/null +++ b/Handler/Settings.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Handler.Settings where + +import Import +import qualified Network.HTTP.Conduit as HTTP +import Text.XML.Lens +import Data.Bits +import Text.XML (parseText) +import qualified Data.Text.Lazy as T +import qualified Data.ByteString.Lazy.Char8 as B + +getSettingsR :: Handler Html +getSettingsR = loginOrDo $ (\u -> do + apiKey <- runDB $ getBy $ UniqueApiUser u + (formWidget, formEnctype) <- generateFormPost $ renderBootstrap3 authFormLayout (authKeyForm (entityVal <$> apiKey) u) + man <- getHttpManager <$> ask + validKey <- case apiKey of + Just (Entity _ key) -> liftIO $ checkApiKey key man + Nothing -> return False + insertionWidget <- return Nothing :: Handler (Maybe Widget) + defaultLayout $(widgetFile "settings") + ) + + +postSettingsR :: Handler Html +postSettingsR = loginOrDo $ (\u -> do + apiKey <- runDB $ getBy $ UniqueApiUser u + ((result,formWidget),formEnctype) <- runFormPost $ renderBootstrap3 authFormLayout (authKeyForm (entityVal <$> apiKey) u) + (success, msg) <- case result of + FormSuccess api -> do mapi <- runDB $ getBy $ UniqueApiUser u + case mapi of + Just (Entity aid _) -> runDB $ replace aid api + Nothing -> runDB $ insert_ api + return (True,[whamlet|Successful inserted Key|]) + FormFailure errs -> return (False,[whamlet|Error:
#{concat $ intersperse "
" errs}|]) + FormMissing -> return (False,[whamlet|Error: No such Form|]) + apiKey' <- runDB $ getBy $ UniqueApiUser u + man <- getHttpManager <$> ask + validKey <- case apiKey' of + Just (Entity _ key) -> liftIO $ checkApiKey key man + Nothing -> return False + insertionWidget <- return . Just $ [whamlet| +$if success +