Drezil/neat
1
0
Fork 0
Code Issues 5 Pull Requests Projects Releases Wiki Activity

Api-Key now gets verified and can be saved/changed

Browse Source
This commit is contained in:
Stefan Dresselhaus
2015-07-20 22:10:30 +02:00
parent a53f7aaac4
commit a707e64cce
14 changed files with 219 additions and 115 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
Application.hs
View File

@@ -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

55
Foundation.hs
View File

@@ -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
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
}
-- 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 -> 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

14
Handler/Home.hs
View File

@@ -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>
$maybe u <- muser
Welcome back #{userName u}
$nothing
Welcome to NEAT.
<div>
Current Auth-ID: #{show maid}.
<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

67
Handler/Register.hs
View File

@@ -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
View 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)

10
Handler/Wallet.hs
View File

@@ -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
View File

@@ -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

7
config/models
View File

@@ -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

3
config/routes
View File

@@ -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
View File

@@ -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)

28
templates/default-layout-wrapper.hamlet
View File

@@ -25,6 +25,34 @@ $newline never
<body>
<div class="container">
<header>
<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">

1
templates/default-layout.lucius
View File

@@ -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
View 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
View File

@@ -0,0 +1,3 @@
input {
width: 100%
}