Merge pull request #192 from aelve/public-db

Add PublicDB type

guide.cabal

@@ -128,6 +128,7 @@ library
                      , patches-vector
                      , random >= 1.1
                      , reroute
+                     , safe
                      , safecopy
                      , safecopy-migrate
                      , scrypt

src/Guide/Main.hs

@@ -24,6 +24,10 @@ import Imports
 
 -- Containers
 import qualified Data.Map as M
+-- ByteString
+import qualified Data.ByteString as BS
+-- Lists
+import Safe (headDef)
 -- Monads and monad transformers
 import Control.Monad.Morph
 -- Text
@@ -46,6 +50,8 @@ import qualified Network.Wai.Metrics      as EKG
 import qualified System.Metrics.Gauge     as EKG.Gauge
 -- acid-state
 import Data.Acid as Acid
+import Data.SafeCopy as SafeCopy
+import Data.Serialize.Get as Cereal
 -- IO
 import System.IO
 import qualified SlaveThread as Slave
@@ -150,11 +156,26 @@ mainWith config = do
         _users = M.empty,
         _dirty = True }
   do args <- getArgs
-     when (args == ["--dry-run"]) $ do
+     let option = headDef "" args
+     when (option == "--dry-run") $ do
        db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
        putStrLn "loaded the database successfully"
        closeAcidState db
        exitSuccess
+     -- USAGE: --load-public <filename>
+     -- loads PublicDB from <filename>, converts it to GlobalState, saves & exits
+     when (option == "--load-public") $ do
+       let path = fromMaybe
+             (error "you haven't provided public DB file name")
+             (args ^? ix 1)
+       (Cereal.runGet SafeCopy.safeGet <$> BS.readFile path) >>= \case
+         Left err -> error err
+         Right publicDB -> do
+           db <- openLocalStateFrom "state/" emptyState
+           Acid.update db (ImportPublicDB publicDB)
+           createCheckpointAndClose' db
+           putStrLn "PublicDB imported to GlobalState"
+           exitSuccess
   -- When we run in GHCi and we exit the main thread, the EKG thread (that
   -- runs the localhost:5050 server which provides statistics) may keep
   -- running. This makes running this in GHCi annoying, because you have to

src/Guide/State.hs

@@ -82,7 +82,15 @@ module Guide.State
   GetUser(..), CreateUser(..), DeleteUser(..), DeleteAllUsers(..),
   LoginUser(..),
 
-  GetAdminUsers(..)
+  GetAdminUsers(..),
+
+  -- * PublicDB
+  PublicDB(..),
+  toPublicDB,
+  fromPublicDB,
+  -- ** queries
+  ImportPublicDB(..),
+  ExportPublicDB(..),
 )
 where
 
@@ -235,6 +243,53 @@ findCategoryByItem itemId s =
           T.unpack (uidToText itemId)
     hasItem category = itemId `elem` (category^..items.each.uid)
 
+-- | 'PublicDB' contains all safe data from 'GlobalState'.
+-- Difference from 'GlobalState':
+-- * 'User' replaced with 'PublicUser'
+-- * Sessions information removed
+-- * Dirty flag removed
+data PublicDB = PublicDB {
+  publicCategories        :: [Category],
+  publicCategoriesDeleted :: [Category],
+  publicActions           :: [(Action, ActionDetails)],
+  publicPendingEdits      :: [(Edit, EditDetails)],
+  publicEditIdCounter     :: Int,
+  publicUsers             :: Map (Uid User) PublicUser}
+  deriving (Show)
+
+-- NOTE: you don't need to write migrations for 'PublicDB' but you still
+-- need to increase the version when the type changes, so that old clients
+-- wouldn't get cryptic error messages like “not enough bytes” when trying
+-- to deserialize a new version of 'PublicDB' that they can't handle.
+deriveSafeCopySorted 0 'base ''PublicDB
+
+-- | Converts 'GlobalState' to 'PublicDB' type stripping private data.
+toPublicDB :: GlobalState -> PublicDB
+toPublicDB GlobalState{..} =
+  PublicDB {
+    publicCategories        = _categories,
+    publicCategoriesDeleted = _categoriesDeleted,
+    publicActions           = _actions,
+    publicPendingEdits      = _pendingEdits,
+    publicEditIdCounter     = _editIdCounter,
+    publicUsers             = fmap userToPublic _users
+  }
+
+-- | Converts 'PublicDB' to 'GlobalState' type filling in non-existing data with
+-- default values.
+fromPublicDB :: PublicDB -> GlobalState
+fromPublicDB PublicDB{..} =
+  GlobalState {
+    _categories        = publicCategories,
+    _categoriesDeleted = publicCategoriesDeleted,
+    _actions           = publicActions,
+    _pendingEdits      = publicPendingEdits,
+    _editIdCounter     = publicEditIdCounter,
+    _sessionStore      = M.empty,
+    _users             = fmap publicUserToUser publicUsers,
+    _dirty             = True
+  }
+
 -- get
 
 getGlobalState :: Acid.Query GlobalState GlobalState
@@ -781,6 +836,14 @@ logoutUserGlobally key = do
 getAdminUsers :: Acid.Query GlobalState [User]
 getAdminUsers = filter (^. userIsAdmin) . toList <$> view users
 
+-- | Populate the database with info from the public DB.
+importPublicDB :: PublicDB -> Acid.Update GlobalState ()
+importPublicDB = put . fromPublicDB
+
+-- | Strip the database from sensitive data and create a 'PublicDB' from it.
+exportPublicDB :: Acid.Query GlobalState PublicDB
+exportPublicDB = toPublicDB <$> ask
+
 makeAcidic ''GlobalState [
   -- queries
   'getGlobalState,
@@ -822,5 +885,9 @@ makeAcidic ''GlobalState [
   'getUser, 'createUser, 'deleteUser, 'deleteAllUsers,
   'loginUser,
 
-  'getAdminUsers
+  'getAdminUsers,
+
+  -- PublicDB
+  'importPublicDB,
+  'exportPublicDB
   ]

src/Guide/Types/User.hs

@@ -15,6 +15,9 @@ module Guide.Types.User
   makeUser,
   verifyUser,
   canCreateUser,
+  PublicUser,
+  userToPublic,
+  publicUserToUser
 )
 where
 
@@ -76,3 +79,36 @@ canCreateUser userFoo userBar =
         fieldNotEq userID,
         fieldNotEq userName,
         fieldNotEq userEmail ]
+
+-- | 'PublicUser' contains all safe User data.
+-- Removed from 'User':
+-- * Password
+data PublicUser = PublicUser {
+  publicUserID      :: Uid User,
+  publicUserName    :: Text,
+  publicUserEmail   :: Text,
+  publicUserIsAdmin :: Bool}
+  deriving (Show)
+
+deriveSafeCopySorted 0 'base ''PublicUser
+
+-- | Converts 'User' to 'PublicUser' type.
+userToPublic :: User -> PublicUser
+userToPublic User{..} =
+  PublicUser {
+    publicUserID      = _userID,
+    publicUserName    = _userName,
+    publicUserEmail   = _userEmail,
+    publicUserIsAdmin = _userIsAdmin
+  }
+
+-- | Converts 'PublicUser' to 'User' filling password with Nothing.
+publicUserToUser :: PublicUser -> User
+publicUserToUser PublicUser{..} =
+  User {
+    _userID       = publicUserID,
+    _userName     = publicUserName,
+    _userEmail    = publicUserEmail,
+    _userPassword = Nothing,
+    _userIsAdmin  = publicUserIsAdmin
+  }