Api-Key now gets verified and can be saved/changed
This commit is contained in:
parent
a53f7aaac4
commit
a707e64cce
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|]
|
||||
|
||||
|
||||
|
||||
11
Import.hs
11
Import.hs
@ -4,3 +4,14 @@ module Import
|
||||
|
||||
import Foundation as Import
|
||||
import Import.NoFoundation as Import
|
||||
import Yesod.Form.Bootstrap3 as Import
|
||||
|
||||
loginOrDo :: (User -> Handler Html) -> Handler Html
|
||||
loginOrDo cont = do
|
||||
maid <- maybeAuthId
|
||||
muid <- case maid of
|
||||
Just uid -> runDB $ get uid
|
||||
Nothing -> return Nothing
|
||||
case muid of
|
||||
Nothing -> redirect (AuthR LoginR)
|
||||
Just u -> cont u
|
||||
|
||||
@ -1,7 +1,11 @@
|
||||
User
|
||||
ident Text
|
||||
name Text
|
||||
charId Int64
|
||||
password Text Maybe
|
||||
lastLogin UTCTime default=now()
|
||||
lastLogin UTCTime
|
||||
tokenExpires UTCTime
|
||||
accessToken Text
|
||||
UniqueUser ident
|
||||
deriving Typeable
|
||||
|
||||
@ -15,6 +19,7 @@ Api
|
||||
user User
|
||||
keyID Int64
|
||||
vCode Text
|
||||
UniqueApiUser user
|
||||
|
||||
Character
|
||||
auth Api
|
||||
|
||||
@ -6,4 +6,5 @@
|
||||
|
||||
/ HomeR GET POST
|
||||
/wallet WalletR GET
|
||||
/register RegisterR GET POST
|
||||
-- /register RegisterR GET POST
|
||||
/settings SettingsR GET POST
|
||||
|
||||
28
neat.cabal
28
neat.cabal
@ -23,7 +23,7 @@ library
|
||||
Handler.Common
|
||||
Handler.Home
|
||||
Handler.Wallet
|
||||
Handler.Register
|
||||
Handler.Settings
|
||||
|
||||
if flag(dev) || flag(library-only)
|
||||
cpp-options: -DDEVELOPMENT
|
||||
@ -49,25 +49,25 @@ library
|
||||
RecordWildCards
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 1.4.1 && < 1.5
|
||||
, yesod-core >= 1.4.6 && < 1.5
|
||||
, yesod-auth >= 1.4.4 && < 1.5
|
||||
, yesod-static >= 1.4.0.3 && < 1.5
|
||||
, yesod-form >= 1.4.0 && < 1.5
|
||||
, yesod-auth-hashdb >= 1.4.0 && < 1.5
|
||||
, yesod >= 1.4.1 && < 1.6
|
||||
, yesod-core >= 1.4.6 && < 1.6
|
||||
, yesod-auth >= 1.4.4 && < 1.6
|
||||
, yesod-static >= 1.4.0.3 && < 1.6
|
||||
, yesod-form >= 1.4.0 && < 1.6
|
||||
, yesod-auth-hashdb >= 1.4.0 && < 1.6
|
||||
, yesod-auth-oauth2 >= 0.1.2
|
||||
, classy-prelude >= 0.10.2
|
||||
, classy-prelude-conduit >= 0.10.2
|
||||
, classy-prelude-yesod >= 0.10.2
|
||||
, bytestring >= 0.9 && < 0.11
|
||||
, text >= 0.11 && < 2.0
|
||||
, persistent >= 2.0 && < 2.2
|
||||
, persistent-postgresql >= 2.1.1 && < 2.2
|
||||
, persistent-template >= 2.0 && < 2.2
|
||||
, persistent >= 2.0 && < 2.3
|
||||
, persistent-postgresql >= 2.1.1 && < 2.3
|
||||
, persistent-template >= 2.0 && < 2.3
|
||||
, template-haskell
|
||||
, shakespeare >= 2.0 && < 2.1
|
||||
, hjsmin >= 0.1 && < 0.2
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
, monad-control >= 0.3 && < 1.1
|
||||
, wai-extra >= 3.0 && < 3.1
|
||||
, yaml >= 0.8 && < 0.9
|
||||
, http-conduit >= 2.1 && < 2.2
|
||||
@ -77,7 +77,7 @@ library
|
||||
, aeson >= 0.6 && < 0.9
|
||||
, conduit >= 1.0 && < 2.0
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, fast-logger >= 2.2 && < 2.3
|
||||
, fast-logger >= 2.2 && < 2.4
|
||||
, wai-logger >= 2.2 && < 2.3
|
||||
, file-embed
|
||||
, safe
|
||||
@ -85,6 +85,10 @@ library
|
||||
, containers
|
||||
, vector
|
||||
, time
|
||||
, HTTP
|
||||
, xml-lens
|
||||
, xml-conduit
|
||||
|
||||
|
||||
executable neat
|
||||
if flag(library-only)
|
||||
|
||||
@ -25,7 +25,35 @@ $newline never
|
||||
<body>
|
||||
<div class="container">
|
||||
<header>
|
||||
<div id="main" role="main">
|
||||
<nav class="navbar navbar-default navbar-fixed-top">
|
||||
<div class="container-fluid">
|
||||
<!-- Brand and toggle get grouped for better mobile display -->
|
||||
<div class="navbar-header">
|
||||
<button type="button" class="navbar-toggle collapsed" data-toggle="collapse" data-target="#bs-example-navbar-collapse-1" aria-expanded="false">
|
||||
<span class="sr-only">Toggle navigation
|
||||
<span class="icon-bar">
|
||||
<span class="icon-bar">
|
||||
<span class="icon-bar">
|
||||
<a class="navbar-brand" href="#">Brand
|
||||
|
||||
<!-- Collect the nav links, forms, and other content for toggling -->
|
||||
<div class="collapse navbar-collapse" id="bs-example-navbar-collapse-1">
|
||||
<ul class="nav navbar-nav">
|
||||
<li><a href="@{HomeR}">Home</a>
|
||||
<li><a href="@{SettingsR}">Settings</a>
|
||||
<!--li class="dropdown">
|
||||
<a href="#" class="dropdown-toggle" data-toggle="dropdown" role="button" aria-haspopup="true" aria-expanded="false">Dropdown <span class="caret"></span>
|
||||
<ul class="dropdown-menu">
|
||||
<li><a href="#">Action</a>
|
||||
<li><a href="#">Another action</a>
|
||||
<li><a href="#">Something else here</a>
|
||||
<li role="separator" class="divider">
|
||||
<li><a href="#">Separated link</a>
|
||||
<li role="separator" class="divider">
|
||||
<li><a href="@SettingsR">Settings</a-->
|
||||
<ul class="nav navbar-nav navbar-right">
|
||||
<li><a href="@{AuthR LogoutR}">Logout</a>
|
||||
<div id="main" role="main">
|
||||
^{pageBody pc}
|
||||
<footer class="footer">
|
||||
<div class="container">
|
||||
|
||||
@ -7,6 +7,7 @@ html {
|
||||
body {
|
||||
/* Margin bottom by footer height */
|
||||
margin-bottom: 60px;
|
||||
margin-top: 60px;
|
||||
}
|
||||
.footer {
|
||||
font-size:x-small;
|
||||
|
||||
19
templates/settings.hamlet
Normal file
19
templates/settings.hamlet
Normal file
@ -0,0 +1,19 @@
|
||||
<div class="container">
|
||||
<div class="panel panel-default">
|
||||
<div class="panel-heading">Auth-Key settings
|
||||
<div class="panel-body">
|
||||
$maybe w <- insertionWidget
|
||||
^{w}
|
||||
<form role=form method=post action=@{SettingsR} enctype=#{formEnctype} class="form-horizontal">
|
||||
^{formWidget}
|
||||
$if validKey
|
||||
<div class="panel panel-success">
|
||||
<div class="panel-heading">API Key
|
||||
<div class="panel-body">
|
||||
<p>This auth-key is working.
|
||||
$else
|
||||
<div class="panel panel-danger">
|
||||
<div class="panel-heading">API Key
|
||||
<div class="panel-body">
|
||||
<p>This auth-key is not suitable.<br>
|
||||
<a href="https://support.eveonline.com/api/Key/CreatePredefined/132648971/275335845">Create API-Key
|
||||
3
templates/settings.lucius
Normal file
3
templates/settings.lucius
Normal file
@ -0,0 +1,3 @@
|
||||
input {
|
||||
width: 100%
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user