Allow API key auth on AddR route

app/migration/Main.hs

@@ -51,8 +51,12 @@ data MigrationOpts
                , privateDefault :: Maybe Bool
                , archiveDefault :: Maybe Bool
                , privacyLock :: Maybe Bool }
+  | CreateApiKey { conn :: Text
+                 , userName :: Text }
   | DeleteUser { conn :: Text
                , userName :: Text }
+  | DeleteApiKey { conn :: Text
+                 , userName :: Text }
   | ImportBookmarks { conn :: Text
                     , userName :: Text
                     , bookmarkFile :: FilePath }
@@ -92,13 +96,33 @@ main = do
           (UniqueUserName userName)
           (User userName hash' Nothing False False False)
           [ UserPasswordHash P.=. hash'
-          , UserApiToken P.=. Nothing
           , UserPrivateDefault P.=. fromMaybe False privateDefault
           , UserArchiveDefault P.=. fromMaybe False archiveDefault
           , UserPrivacyLock P.=. fromMaybe False privacyLock
           ]
         pure () :: DB ()
 
+    CreateApiKey {..} ->
+      P.runSqlite conn $ do
+        apiKey@(ApiKey plainKey) <- liftIO generateApiKey
+        muser <- P.getBy (UniqueUserName userName)
+        case muser of
+          Nothing -> liftIO (print (userName ++ " not found"))
+          Just (P.Entity uid _) -> do
+            -- API key is only displayed once after creation,
+            -- since it is stored in hashed form.
+            let hashedKey = hashApiKey apiKey
+            P.update uid  [ UserApiToken P.=. Just hashedKey ]
+            liftIO $ print plainKey
+
+    DeleteApiKey {..} ->
+      P.runSqlite conn $ do
+        muser <- P.getBy (UniqueUserName userName)
+        case muser of
+          Nothing -> liftIO (print (userName ++ " not found"))
+          Just (P.Entity uid _) -> do
+            P.update uid  [ UserApiToken P.=. Nothing ]
+
     DeleteUser {..} ->
       P.runSqlite conn $ do
         muser <- P.getBy (UniqueUserName userName)

espial.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.34.6.
 --
 -- see: https://github.com/sol/hpack
 
@@ -163,6 +163,7 @@ library
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
     , bytestring >=0.9 && <0.11
@@ -173,6 +174,7 @@ library
     , conduit >=1.0 && <2.0
     , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
     , entropy
@@ -273,6 +275,7 @@ executable espial
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
     , bytestring >=0.9 && <0.11
@@ -283,6 +286,7 @@ executable espial
     , conduit >=1.0 && <2.0
     , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
     , entropy
@@ -380,6 +384,7 @@ executable migration
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
     , bytestring >=0.9 && <0.11
@@ -390,6 +395,7 @@ executable migration
     , conduit >=1.0 && <2.0
     , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
     , entropy
@@ -493,6 +499,7 @@ test-suite test
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
     , bytestring >=0.9 && <0.11
@@ -503,6 +510,7 @@ test-suite test
     , conduit >=1.0 && <2.0
     , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
     , entropy

package.yaml

@@ -141,6 +141,8 @@ dependencies:
 - parser-combinators
 - html-entities
 - connection
+- base64
+- cryptohash-sha256
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -17,6 +17,7 @@ import Yesod.Auth.Message
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text.Encoding as TE
 import qualified Yesod.Core.Unsafe as Unsafe
+import qualified Network.Wai as Wai
 
 data App = App
     { appSettings    :: AppSettings
@@ -67,8 +68,20 @@ instance Yesod App where
             else id
 
     yesodMiddleware :: HandlerFor App res -> HandlerFor App res
-    yesodMiddleware = customMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
+    yesodMiddleware = customMiddleware . defaultYesodMiddleware . customCsrfMiddleware
       where
+        customCsrfMiddleware handler = do
+          maybeRoute <- getCurrentRoute
+          dontCheckCsrf <- case maybeRoute of
+            -- `maybeAuthId` checks for the validity of the Authorization
+            -- header anyway, but it is still a good idea to limit this
+            -- flexibility to designated routes.
+            -- For the time being, `AddR` is the only route that accepts an
+            -- authentication token.
+            Just AddR -> isJust <$> lookupHeader "Authorization"
+            _ -> pure False
+          (if dontCheckCsrf then id else defaultCsrfMiddleware) handler
+
         customMiddleware handler = do
           addHeader "X-Frame-Options" "DENY"
           yesod <- getYesod
@@ -167,6 +180,24 @@ instance YesodAuth App where
   onLogout =
     deleteSession userNameKey
   redirectToReferer = const True
+  maybeAuthId = do
+    req <- waiRequest
+    let mAuthHeader = lookup "Authorization" (Wai.requestHeaders req)
+        extractKey = stripPrefix "ApiKey " . TE.decodeUtf8
+    case mAuthHeader of
+      Just authHeader ->
+        case extractKey authHeader of
+          Just apiKey -> do
+            user <- liftHandler $ runDB $ getApiKeyUser (ApiKey apiKey)
+            let userId = entityKey <$> user
+            pure userId
+          -- Since we disable CSRF middleware in the presence of Authorization
+          -- header, we need to explicitly check for the validity of the header
+          -- content. Otherwise, a dummy Authorization header with garbage input
+          -- could be provided to circumvent CSRF token requirement, making the app
+          -- vulnerable to CSRF attacks.
+          Nothing -> pure Nothing
+      _ -> defaultMaybeAuthId
 
 instance YesodAuthPersist App
 

src/Model.hs

@@ -34,7 +34,7 @@ User json
   Id Int64
   name Text
   passwordHash BCrypt
-  apiToken Text Maybe
+  apiToken HashedApiKey Maybe
   privateDefault Bool
   archiveDefault Bool
   privacyLock Bool
@@ -159,6 +159,10 @@ getUserByName :: UserNameP -> DB (Maybe (Entity User))
 getUserByName (UserNameP uname) =
   selectFirst [UserName CP.==. uname] []
 
+getApiKeyUser :: ApiKey -> DB (Maybe (Entity User))
+getApiKeyUser apiKey =
+  selectFirst [UserApiToken CP.==. Just (hashApiKey apiKey)] []
+
 -- returns a list of pair of bookmark with tags merged into a string
 bookmarksTagsQuery
   :: Key User

src/ModelCustom.hs

@@ -12,6 +12,8 @@ import qualified Data.Aeson as A
 import System.Entropy (getEntropy)
 import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Base64.URL as Base64Url
+import qualified Crypto.Hash.SHA256 as SHA256
 
 mkSlug :: Int -> IO T.Text
 mkSlug size =
@@ -58,3 +60,18 @@ hashPassword rawPassword = do
 validatePasswordHash :: BCrypt -> T.Text -> Bool
 validatePasswordHash hash' pass = do
   validatePassword (TE.encodeUtf8 (unBCrypt hash')) (TE.encodeUtf8 pass)
+
+newtype ApiKey = ApiKey { unApiKey :: T.Text }
+
+newtype HashedApiKey
+  = HashedApiKey T.Text
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (PersistField, PersistFieldSql, A.FromJSON, A.ToJSON)
+
+generateApiKey :: IO ApiKey
+generateApiKey = do
+  bytes <- getEntropy 32
+  pure $ ApiKey $ Base64Url.encodeBase64 bytes
+
+hashApiKey :: ApiKey -> HashedApiKey
+hashApiKey = HashedApiKey . TE.decodeUtf8 . Base64Url.encodeBase64' . SHA256.hash . TE.encodeUtf8 . unApiKey