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

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

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.HashDB    (authHashDB)
-import Yesod.Auth.OAuth2.EveOnline (oauth2EveImage,ImageType(..))
+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
+                       Nothing -> return $ ServerError "Problems extracting Access-Token"
-    {-getAuthId creds = do
+        where
-           auth <- authenticate creds
+          extra = credsExtra creds
-           return $ case auth of
+          fromExtra = do
-               Authentication auid -> Just auid
+                    expires <- getFromExtra "expires" extra
-               _ -> Nothing-}
+                    token   <- getFromExtra "accessToken" extra
-    --getAuthIdHashDB AuthR (Just . UniqueUser) creds --authenticate on own site
+                    name    <- getFromExtra "charName" extra
-    {-do
+                    cid     <- getFromExtra "charId" extra >>= readMay
-      runDB $ do
+                    expiry  <- parseTimeM True defaultTimeLocale "%FT%X" (unpack expires) :: Maybe UTCTime
-        x <- getBy $ UniqueUser $ credsIdent creds
+                                                  -- %F = YYYY-MM-DD
-        case x of
+                                                  -- %X = HH-MM-SS
-            Just (Entity uid _) -> return $ Just uid
+                    return (expiry,token,name,cid)
-            Nothing -> return Nothing-}
+          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
+    authPlugins _ = [ --authBrowserId def
-                    , authHashDB (Just . UniqueUser)
+                    --, authHashDB (Just . UniqueUser)
-                    , oauth2EveImage "" "" BigBlack
+                      oauth2Eve "346ee0ad8f974e30be6bf422f40d891b" "kXnZd7f3pmRCvePiBPQcTL2aRcgBHSgPRxc6VNYT" BigBlack
                     ]
 
     authHttpManager = getHttpManager

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

Handler/Register.hs

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

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

Handler/Wallet.hs

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

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

config/models

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

config/routes

@@ -6,4 +6,5 @@
 
 / HomeR GET POST
 /wallet WalletR GET
-/register RegisterR GET POST
+-- /register RegisterR GET POST
+/settings SettingsR GET POST

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                         >= 1.4.1      && < 1.6
-                 , yesod-core                    >= 1.4.6      && < 1.5
+                 , yesod-core                    >= 1.4.6      && < 1.6
-                 , yesod-auth                    >= 1.4.4      && < 1.5
+                 , yesod-auth                    >= 1.4.4      && < 1.6
-                 , yesod-static                  >= 1.4.0.3    && < 1.5
+                 , yesod-static                  >= 1.4.0.3    && < 1.6
-                 , yesod-form                    >= 1.4.0      && < 1.5
+                 , yesod-form                    >= 1.4.0      && < 1.6
-                 , yesod-auth-hashdb             >= 1.4.0      && < 1.5
+                 , 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                    >= 2.0        && < 2.3
-                 , persistent-postgresql         >= 2.1.1      && < 2.2
+                 , persistent-postgresql         >= 2.1.1      && < 2.3
-                 , persistent-template           >= 2.0        && < 2.2
+                 , 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)

templates/default-layout-wrapper.hamlet

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

templates/default-layout.lucius

@@ -7,6 +7,7 @@ html {
 body {
   /* Margin bottom by footer height */
   margin-bottom: 60px;
+  margin-top: 60px;
 }
 .footer {
   font-size:x-small;

templates/settings.hamlet

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

templates/settings.lucius

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