Use file based switches to relax keyfile loading rules

src/Data/KeyFile.hs

@@ -15,14 +15,17 @@
 
 module Data.KeyFile
     ( KeyFile (..)
+    , KeyFileLoadMode ()
+    , determineKeyFileLoadMode
     , loadKeyFile
     )
 where
 
 import Prelude
 
+import Control.Monad
 import Data.ByteString (ByteString)
-import System.Directory (doesFileExist)
+import System.Directory
 
 import qualified Data.ByteString as B (readFile, writeFile)
 
@@ -31,16 +34,46 @@ class KeyFile a where
     parseKey    :: ByteString -> IO a
     renderKey   :: a -> ByteString
 
-loadKeyFile :: KeyFile a => Bool -> FilePath -> IO a
+data KeyFileLoadMode
-loadKeyFile setup path = do
+    = WriteAll
+    | ImportExisting
+    | LoadAll
+    | WriteMissing
+
+determineKeyFileLoadMode :: Bool -> IO KeyFileLoadMode
+determineKeyFileLoadMode setup = do
+    laxSetup <- checkSwitch "_keyfile_import_existing"
+    laxLater <- checkSwitch "_keyfile_write_missing"
+    if setup
+        then do
+            when laxLater $ fail "Non-setup switch present during setup"
+            return $ if laxSetup then ImportExisting else WriteAll
+        else do
+            when laxSetup $ fail "Setup switch present after initial setup"
+            return $ if laxLater then WriteMissing else LoadAll
+    where
+    checkSwitch file = do
+        exists <- doesFileExist file
+        if exists
+            then do
+                blank <- (== 0) <$> getFileSize file
+                if blank
+                    then do
+                        removeFile file
+                        return True
+                    else fail $ "Switch file " ++ file ++ "isn't empty!"
+            else return False
+
+loadKeyFile :: KeyFile a => KeyFileLoadMode -> FilePath -> IO a
+loadKeyFile mode path = do
     e <- doesFileExist path
     if e
-        then if setup
+        then case mode of
-                then fail $ "loadKeyFile: Initial setup but file already exists: " ++ path
+                WriteAll -> fail $ "loadKeyFile: Initial setup but file already exists: " ++ path
-                else parseKey =<< B.readFile path
+                _        -> parseKey =<< B.readFile path
-        else if setup
+        else case mode of
-                then do
+                LoadAll -> fail $ "loadKeyFile: File not found: " ++ path
+                _       -> do
                     k <- generateKey
                     B.writeFile path $ renderKey k
                     return k
-                else fail $ "loadKeyFile: File not found: " ++ path

src/Vervis/Application.hs

@@ -60,7 +60,7 @@ import Control.Concurrent.Local (forkCheck)
 
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 
-import Data.KeyFile (loadKeyFile)
+import Data.KeyFile
 import Web.Hashids.Local
 
 import Vervis.ActorKey (generateActorKey, actorKeyRotator)
@@ -155,8 +155,10 @@ makeFoundation appSettings = do
         (pgPoolSize $ appDatabaseConf appSettings)
 
     setup <- isInitialSetup pool schemaBackend
-    capSignKey <- loadKeyFile setup $ appCapabilitySigningKeyFile appSettings
+    loadMode <- determineKeyFileLoadMode setup
-    hashidsSalt <- loadKeyFile setup $ appHashidsSaltFile appSettings
+
+    capSignKey <- loadKeyFile loadMode $ appCapabilitySigningKeyFile appSettings
+    hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings
     let hashidsCtx = hashidsContext hashidsSalt
         hashidEncode = decodeUtf8 . encodeInt64 hashidsCtx
         hashidDecode = decodeInt64 hashidsCtx . encodeUtf8