Api-Key now gets verified and can be saved/changed
This commit is contained in:
Stefan Dresselhaus
@ -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|
|
||||
<h1>
|
||||
Welcome to NEAT.
|
||||
<div>
|
||||
Current Auth-ID: #{show maid}.
|
||||
$maybe u <- muser
|
||||
Welcome back #{userName u}
|
||||
$nothing
|
||||
Welcome to NEAT.
|
||||
<div>
|
||||
$maybe u <- maid
|
||||
<p>
|
||||
Data: #{show u}<br>
|
||||
<a href=@{AuthR LogoutR}>Logout
|
||||
<br>
|
||||
<a href=@{WalletR}>Wallet
|
||||
<br>
|
||||
<a href=@{SettingsR}>Settings
|
||||
$nothing
|
||||
<p>
|
||||
<a href=@{AuthR LoginR}>Login
|
||||
<p>
|
||||
<a href=@{RegisterR}>Register Account
|
||||
|]
|
||||
{-
|
||||
(formWidget, formEnctype) <- generateFormPost sampleForm
|
||||
|
||||
@ -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|
|
||||
<h1>Register
|
||||
<form method=post action=@{RegisterR} enctype=#{registerEnctype}>
|
||||
^{registerWidget}
|
||||
|]
|
||||
|
||||
postRegisterR :: Handler Html
|
||||
postRegisterR = do
|
||||
((result,registerWidget), registerEnctype) <- runFormPost registerForm
|
||||
let again err = defaultLayout $ do
|
||||
setTitle "Register"
|
||||
[whamlet|
|
||||
<div class="alert alert-danger fade in"><strong>Error:</strong> #{err}
|
||||
<h1>Register
|
||||
<form method=post action=@{RegisterR} enctype=#{registerEnctype}>
|
||||
^{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}
|
||||
<p>
|
||||
Username ^{fvInput nameView}
|
||||
<p>
|
||||
Password ^{fvInput pwView}
|
||||
<p>
|
||||
Confirm password ^{fvInput pwcView}
|
||||
<p>
|
||||
Email ^{fvInput emailView}
|
||||
<input type=submit value="register">
|
||||
|]
|
||||
return (registerRes, widget)
|
||||
74
Handler/Settings.hs
Normal file
74
Handler/Settings.hs
Normal file
@ -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:<br>#{concat $ intersperse "<br>" 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
|
||||
<div class="alert alert-success" role="alert">^{msg}
|
||||
$else
|
||||
<div class="alert alert-danger" role="alert">^{msg}
|
||||
|] :: Handler (Maybe Widget)
|
||||
defaultLayout $(widgetFile "settings")
|
||||
)
|
||||
|
||||
checkApiKey :: Api -> Manager -> IO Bool
|
||||
checkApiKey (Api _ key code) manager = do
|
||||
url <- parseUrl $ "https://api.eveonline.com/account/APIKeyInfo.xml.aspx?keyID="++(show key)++"&vCode="++(unpack code)
|
||||
response <- HTTP.httpLbs url manager
|
||||
xml' <- return . parseText def . T.pack . B.unpack . responseBody $ response
|
||||
case xml' of
|
||||
Left _ -> return False
|
||||
Right xml -> do
|
||||
accessMasks <- return $ xml ^.. root . el "eveapi" ./ el "result" ./ el "key" . attribute "accessMask"
|
||||
case headMay accessMasks >>= liftM unpack >>= readMay of
|
||||
Just am -> return $ am .&. 132648971 == (132648971 :: Integer)
|
||||
_ -> return False
|
||||
`catch` (\ (_ :: HttpException) -> return False)
|
||||
|
||||
authKeyForm :: Maybe Api -> User -> AForm Handler Api
|
||||
authKeyForm ma u = Api
|
||||
<$> pure u
|
||||
<*> areq intField (withPlaceholder "keyID" "keyID") (apiKeyID <$> ma)
|
||||
<*> areq textField (withPlaceholder "vCode" "vCode") (apiVCode <$> ma)
|
||||
<* bootstrapSubmit ("Submit" :: BootstrapSubmit Text)
|
||||
|
||||
authFormLayout :: BootstrapFormLayout
|
||||
authFormLayout = BootstrapHorizontalForm (ColLg 0) (ColLg 1) (ColLg 0) (ColLg 11)
|
||||
@ -3,4 +3,12 @@ module Handler.Wallet where
|
||||
import Import
|
||||
|
||||
getWalletR :: Handler Html
|
||||
getWalletR = error "Not yet implemented: getWalletR"
|
||||
getWalletR = do
|
||||
defaultLayout $ [whamlet|
|
||||
<h1>Transactions in the last xx hours
|
||||
|
||||
<h1>Statistices for the last xx days
|
||||
|
||||
|]
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user