Permalink
Browse files

Add support for storing role and meta data as json

Encode empty roles/meta data as NULLs in the database

Favor using Data.Text over ByteStrings for storing JSON text in the
database.

This patch requires the latest sqlite-simple version from github.
This will be released shortly on hackage.
  • Loading branch information...
1 parent 656221c commit 88d538d4040027e6174ca9b48d299b93a97220d8 @alexanderkjeldaas alexanderkjeldaas committed Feb 21, 2013
Showing with 57 additions and 9 deletions.
  1. +1 −1 example/example.cabal
  2. +5 −2 snaplet-sqlite-simple.cabal
  3. +35 −5 src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs
  4. +16 −1 test/Tests.hs
View
2 example/example.cabal
@@ -35,7 +35,7 @@ Executable example
resource-pool-catchio >= 0.2 && < 0.3,
xmlhtml >= 0.1,
either == 3.1.*,
- errors >= 1.3 && < 1.4
+ errors >= 1.3 && < 1.5
if flag(development)
build-depends:
View
7 snaplet-sqlite-simple.cabal
@@ -47,6 +47,7 @@ Library
Paths_snaplet_sqlite_simple
build-depends:
+ aeson >= 0.6 && < 0.7,
base >= 4 && < 5,
bytestring >= 0.9.1 && < 0.11,
clientsession >= 0.8 && < 0.9,
@@ -77,6 +78,7 @@ test-suite test
, SafeCWD
build-depends:
+ aeson >= 0.6 && < 0.7,
HUnit >= 1.2 && < 2,
MonadCatchIO-transformers >= 0.2 && < 0.4,
base >= 4 && < 5,
@@ -85,7 +87,7 @@ test-suite test
configurator >= 0.1 && < 0.3,
containers >= 0.3,
directory >= 1.0 && < 1.3,
- errors >= 1.3.1 && < 1.4,
+ errors >= 1.3.1 && < 1.5,
lens >= 3.7.0.1 && < 3.9,
mtl >= 2,
snap-core,
@@ -97,7 +99,8 @@ test-suite test
test-framework-hunit >= 0.2.7 && < 0.4,
text >= 0.11 && < 0.12,
time >= 1.1,
- transformers >= 0.2
+ transformers >= 0.2,
+ unordered-containers >= 0.2 && < 0.3
default-extensions:
FlexibleInstances
View
40 src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs
@@ -39,11 +39,14 @@ module Snap.Snaplet.Auth.Backends.SqliteSimple
------------------------------------------------------------------------------
import Control.Concurrent
+import qualified Data.Aeson as A
import qualified Data.Configurator as C
-import qualified Data.HashMap.Lazy as HM
import Data.Maybe
+import qualified Data.HashMap.Lazy as HM
import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
import qualified Database.SQLite.Simple as S
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.FromRow
@@ -152,6 +155,10 @@ upgradeSchema conn pam fromVersion = do
S.execute_ conn (addColumnQ (colResetToken pam))
S.execute_ conn (addColumnQ (colResetRequestedAt pam))
+ upgrade 2 = do
+ S.execute_ conn (addColumnQ (colRoles pam))
+ S.execute_ conn (addColumnQ (colMeta pam))
+
upgrade _ = error "unknown version"
addColumnQ (c,t) =
@@ -167,6 +174,7 @@ createTableIfMissing SqliteAuthManager{..} = do
unless authTblExists $ createInitialSchema conn pamTable
upgradeSchema conn pamTable 0
upgradeSchema conn pamTable 1
+ upgradeSchema conn pamTable 2
buildUid :: Int -> UserId
@@ -199,8 +207,8 @@ instance FromRow AuthUser where
<*> _userUpdatedAt
<*> _userResetToken
<*> _userResetRequestedAt
- <*> _userRoles
- <*> _userMeta
+ <*> decodeRoles
+ <*> decodeMeta
where
!_userId = field
!_userLogin = field
@@ -220,8 +228,16 @@ instance FromRow AuthUser where
!_userUpdatedAt = field
!_userResetToken = field
!_userResetRequestedAt = field
- !_userRoles = pure []
- !_userMeta = pure HM.empty
+ !_userRoles = field :: RowParser (Maybe LT.Text)
+ !_userMeta = field :: RowParser (Maybe LT.Text)
+
+ decodeRoles = do
+ roles <- fmap (fmap (maybeToList . A.decode' . LT.encodeUtf8)) _userRoles
+ return $ fromMaybe [] roles
+
+ decodeMeta = do
+ meta <- fmap (fmap (fromMaybe HM.empty . A.decode' . LT.encodeUtf8)) _userMeta
+ return $ fromMaybe HM.empty meta
querySingle :: (ToRow q, FromRow a)
@@ -262,6 +278,8 @@ data AuthTable
, colUpdatedAt :: (Text, Text)
, colResetToken :: (Text, Text)
, colResetRequestedAt :: (Text, Text)
+ , colRoles :: (Text, Text)
+ , colMeta :: (Text, Text)
}
@@ -288,6 +306,8 @@ defAuthTable
, colUpdatedAt = ("updated_at", "timestamp")
, colResetToken = ("reset_token", "text")
, colResetRequestedAt = ("reset_requested_at", "timestamp")
+ , colRoles = ("roles_json", "text")
+ , colMeta = ("meta_json", "text")
}
-- | List of deconstructors so it's easier to extract column names from an
@@ -312,7 +332,16 @@ colDef =
, (colUpdatedAt , S.toField . userUpdatedAt)
, (colResetToken , S.toField . userResetToken)
, (colResetRequestedAt, S.toField . userResetRequestedAt)
+ , (colRoles , S.toField . encodeOrNull . userRoles)
+ , (colMeta , S.toField . encodeOrNullHM . userMeta)
]
+ where
+ encodeOrNull [] = Nothing
+ encodeOrNull x = Just . LT.decodeUtf8 . A.encode $ x
+
+ encodeOrNullHM hm | HM.null hm = Nothing
+ | otherwise = Just . LT.decodeUtf8 . A.encode $ hm
+
colNames :: AuthTable -> T.Text
colNames pam =
@@ -341,6 +370,7 @@ saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId
, " = ?"
]
, params ++ [S.toField $ unUid uid])
+ -- The list of column names
cols = map (fst . ($at) . fst) $ tail colDef
vals = map (const "?") cols
params = map (($u) . snd) $ tail colDef
View
17 test/Tests.hs
@@ -6,6 +6,9 @@ module Tests
------------------------------------------------------------------------------
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as BL
+import qualified Data.HashMap.Lazy as HM
import qualified Data.Map as M
import qualified Data.Text as T
import Test.Framework
@@ -129,6 +132,8 @@ testCreateUserGood = testCase "createUser good params" assertGoodUser
assertEqual "local host ip" Nothing (userLastLoginIp u)
assertEqual "locked until" Nothing (userLockedOutUntil u)
assertEqual "empty email" Nothing (userEmail u)
+ assertEqual "roles" [] (userRoles u)
+ assertEqual "meta" HM.empty (userMeta u)
------------------------------------------------------------------------------
-- Create a user, modify it, persist it and load again, check fields ok.
@@ -150,16 +155,26 @@ testUpdateUser = testCase "createUser + update good params" assertGoodUser
assertEqual "locked until" Nothing (userLockedOutUntil u)
assertEqual "local host ip" (Just "127.0.0.1") (userCurrentLoginIp u)
assertEqual "no previous login" Nothing (userLastLoginIp u)
- let saveHdl = with auth $ saveUser (u { userLogin = "bar" })
+ let saveHdl = with auth $ saveUser (u { userLogin = "bar"
+ , userRoles = roles
+ , userMeta = meta })
res <- evalHandler (ST.get "" M.empty) saveHdl appInit
either (assertFailure . show) checkUpdatedUser res
+ roles = [Role $ BL.pack "Superman", Role $ BL.pack "Journalist"]
+ meta = HM.fromList [ (T.pack "email-verified",
+ A.toJSON $ T.pack "yes")
+ , (T.pack "suppress-products",
+ A.toJSON [T.pack "Kryptonite"]) ]
+
checkUpdatedUser (Left _) = assertBool "failed saveUser" False
checkUpdatedUser (Right u) = do
assertEqual "login rename ok?" "bar" (userLogin u)
assertEqual "login count" 1 (userLoginCount u)
assertEqual "local host ip" (Just "127.0.0.1") (userCurrentLoginIp u)
assertEqual "local host ip" Nothing (userLastLoginIp u)
+ assertEqual "account roles" roles (userRoles u)
+ assertEqual "account meta data" meta (userMeta u)
let loginHdl = with auth $ loginByUsername "bar" (ClearText "foo") True
res <- evalHandler (ST.get "" M.empty) loginHdl appInit
either (assertFailure . show) (assertBool "login as 'bar' ok?" . isRight) res

0 comments on commit 88d538d

Please sign in to comment.