{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings #-}
-- |This module provides a type for interacting with a
-- filesystem-backed 'MigrationStore'.
module Database.Schema.Migrations.Filesystem
    ( FilesystemStoreSettings(..)
    , migrationFromFile
    , migrationFromPath
    , filesystemStore
    )
where

import Prelude

import System.Directory ( getDirectoryContents, doesFileExist )
import System.FilePath ( (</>), takeExtension, dropExtension, takeBaseName )
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as BSC
import Data.String.Conversions ( cs, (<>) )

import Data.Typeable ( Typeable )
import Data.Time.Clock ( UTCTime )
import Data.Time () -- for UTCTime Show instance
import qualified Data.Map as Map

import Control.Applicative ( (<$>) )
import Control.Monad ( filterM )
import Control.Exception ( Exception(..), throw, catch )

import Data.Aeson as J (Object, Value(String, Null))
import Data.HashMap.Strict as M (toList)
import Data.Yaml

import Database.Schema.Migrations.Migration
    ( Migration(..)
    , emptyMigration
    )
import Database.Schema.Migrations.Filesystem.Serialize
import Database.Schema.Migrations.Store

type FieldProcessor = Text -> Migration -> Maybe Migration

data FilesystemStoreSettings = FSStore { FilesystemStoreSettings -> FilePath
storePath :: FilePath }

data FilesystemStoreError = FilesystemStoreError String
                            deriving (Int -> FilesystemStoreError -> ShowS
[FilesystemStoreError] -> ShowS
FilesystemStoreError -> FilePath
(Int -> FilesystemStoreError -> ShowS)
-> (FilesystemStoreError -> FilePath)
-> ([FilesystemStoreError] -> ShowS)
-> Show FilesystemStoreError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FilesystemStoreError] -> ShowS
$cshowList :: [FilesystemStoreError] -> ShowS
show :: FilesystemStoreError -> FilePath
$cshow :: FilesystemStoreError -> FilePath
showsPrec :: Int -> FilesystemStoreError -> ShowS
$cshowsPrec :: Int -> FilesystemStoreError -> ShowS
Show, Typeable)

instance Exception FilesystemStoreError

throwFS :: String -> a
throwFS :: FilePath -> a
throwFS = FilesystemStoreError -> a
forall a e. Exception e => e -> a
throw (FilesystemStoreError -> a)
-> (FilePath -> FilesystemStoreError) -> FilePath -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilesystemStoreError
FilesystemStoreError

filenameExtension :: String
filenameExtension :: FilePath
filenameExtension = FilePath
".yml"

filenameExtensionTxt :: String
filenameExtensionTxt :: FilePath
filenameExtensionTxt = FilePath
".txt"

filesystemStore :: FilesystemStoreSettings -> MigrationStore
filesystemStore :: FilesystemStoreSettings -> MigrationStore
filesystemStore FilesystemStoreSettings
s =
    MigrationStore :: (Text -> IO (Either FilePath Migration))
-> (Migration -> IO ())
-> IO [Text]
-> (Text -> IO FilePath)
-> MigrationStore
MigrationStore { fullMigrationName :: Text -> IO FilePath
fullMigrationName = ShowS -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
addNewMigrationExtension (IO FilePath -> IO FilePath)
-> (Text -> IO FilePath) -> Text -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilesystemStoreSettings -> Text -> IO FilePath
fsFullMigrationName FilesystemStoreSettings
s

                   , loadMigration :: Text -> IO (Either FilePath Migration)
loadMigration = \Text
theId -> FilesystemStoreSettings -> Text -> IO (Either FilePath Migration)
migrationFromFile FilesystemStoreSettings
s Text
theId

                   , getMigrations :: IO [Text]
getMigrations = do
                       [FilePath]
contents <- FilePath -> IO [FilePath]
getDirectoryContents (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilesystemStoreSettings -> FilePath
storePath FilesystemStoreSettings
s
                       let migrationFilenames :: [FilePath]
migrationFilenames = [ FilePath
f | FilePath
f <- [FilePath]
contents, FilePath -> Bool
isMigrationFilename FilePath
f ]
                           fullPaths :: [(FilePath, FilePath)]
fullPaths = [ (FilePath
f, FilesystemStoreSettings -> FilePath
storePath FilesystemStoreSettings
s FilePath -> ShowS
</> FilePath
f) | FilePath
f <- [FilePath]
migrationFilenames ]
                       [(FilePath, FilePath)]
existing <- ((FilePath, FilePath) -> IO Bool)
-> [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\(FilePath
_, FilePath
full) -> FilePath -> IO Bool
doesFileExist FilePath
full) [(FilePath, FilePath)]
fullPaths
                       [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [ FilePath -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension FilePath
short | (FilePath
short, FilePath
_) <- [(FilePath, FilePath)]
existing ]

                   , saveMigration :: Migration -> IO ()
saveMigration = \Migration
m -> do
                       FilePath
filename <- FilesystemStoreSettings -> Text -> IO FilePath
fsFullMigrationName FilesystemStoreSettings
s (Text -> IO FilePath) -> Text -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Migration -> Text
mId Migration
m
                       FilePath -> ByteString -> IO ()
BSC.writeFile (ShowS
forall a b. ConvertibleStrings a b => a -> b
cs ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
addNewMigrationExtension FilePath
filename) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Migration -> ByteString
serializeMigration Migration
m
                   }

addNewMigrationExtension :: FilePath -> FilePath
addNewMigrationExtension :: ShowS
addNewMigrationExtension FilePath
path = FilePath
path FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
filenameExtension

addMigrationExtension :: FilePath -> String -> FilePath
addMigrationExtension :: FilePath -> ShowS
addMigrationExtension FilePath
path FilePath
ext = FilePath
path FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
ext

-- |Build path to migrations without extension.
fsFullMigrationName :: FilesystemStoreSettings -> Text -> IO FilePath
fsFullMigrationName :: FilesystemStoreSettings -> Text -> IO FilePath
fsFullMigrationName FilesystemStoreSettings
s Text
name = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilesystemStoreSettings -> FilePath
storePath FilesystemStoreSettings
s FilePath -> ShowS
</> Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs Text
name

isMigrationFilename :: String -> Bool
isMigrationFilename :: FilePath -> Bool
isMigrationFilename FilePath
path = (ShowS
forall a b. ConvertibleStrings a b => a -> b
cs ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
takeExtension FilePath
path) FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
filenameExtension, FilePath
filenameExtensionTxt]

-- |Given a store and migration name, read and parse the associated
-- migration and return the migration if successful.  Otherwise return
-- a parsing error message.
migrationFromFile :: FilesystemStoreSettings -> Text -> IO (Either String Migration)
migrationFromFile :: FilesystemStoreSettings -> Text -> IO (Either FilePath Migration)
migrationFromFile FilesystemStoreSettings
store Text
name =
    FilesystemStoreSettings -> Text -> IO FilePath
fsFullMigrationName FilesystemStoreSettings
store (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
name) IO FilePath
-> (FilePath -> IO (Either FilePath Migration))
-> IO (Either FilePath Migration)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO (Either FilePath Migration)
migrationFromPath

-- |Given a filesystem path, read and parse the file as a migration
-- return the 'Migration' if successful.  Otherwise return a parsing
-- error message.
migrationFromPath :: FilePath -> IO (Either String Migration)
migrationFromPath :: FilePath -> IO (Either FilePath Migration)
migrationFromPath FilePath
path = do
  let name :: Text
name = FilePath -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
takeBaseName FilePath
path
  (Migration -> Either FilePath Migration
forall a b. b -> Either a b
Right (Migration -> Either FilePath Migration)
-> IO Migration -> IO (Either FilePath Migration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Migration
process Text
name) IO (Either FilePath Migration)
-> (FilesystemStoreError -> IO (Either FilePath Migration))
-> IO (Either FilePath Migration)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(FilesystemStoreError FilePath
s) -> Either FilePath Migration -> IO (Either FilePath Migration)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath Migration -> IO (Either FilePath Migration))
-> Either FilePath Migration -> IO (Either FilePath Migration)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Migration
forall a b. a -> Either a b
Left (FilePath -> Either FilePath Migration)
-> FilePath -> Either FilePath Migration
forall a b. (a -> b) -> a -> b
$ FilePath
"Could not parse migration " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
s)

  where
    readMigrationFile :: IO (HashMap Text Value)
readMigrationFile = do
      Bool
ymlExists <- FilePath -> IO Bool
doesFileExist (ShowS
addNewMigrationExtension FilePath
path)
      if Bool
ymlExists
        then FilePath -> IO (HashMap Text Value)
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
decodeFileThrow (ShowS
addNewMigrationExtension FilePath
path) IO (HashMap Text Value)
-> (ParseException -> IO (HashMap Text Value))
-> IO (HashMap Text Value)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(ParseException
e::ParseException) -> FilePath -> IO (HashMap Text Value)
forall a. FilePath -> a
throwFS (FilePath -> IO (HashMap Text Value))
-> FilePath -> IO (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$ ParseException -> FilePath
forall a. Show a => a -> FilePath
show ParseException
e)
        else FilePath -> IO (HashMap Text Value)
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
decodeFileThrow (FilePath -> ShowS
addMigrationExtension FilePath
path FilePath
filenameExtensionTxt) IO (HashMap Text Value)
-> (ParseException -> IO (HashMap Text Value))
-> IO (HashMap Text Value)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(ParseException
e::ParseException) -> FilePath -> IO (HashMap Text Value)
forall a. FilePath -> a
throwFS (FilePath -> IO (HashMap Text Value))
-> FilePath -> IO (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$ ParseException -> FilePath
forall a. Show a => a -> FilePath
show ParseException
e)

    process :: Text -> IO Migration
process Text
name = do
      HashMap Text Value
yaml <- IO (HashMap Text Value)
readMigrationFile

      -- Convert yaml structure into basic key/value map
      let fields :: [(Text, Text)]
fields = HashMap Text Value -> [(Text, Text)]
getFields HashMap Text Value
yaml
          missing :: [Text]
missing = [(Text, Text)] -> [Text]
missingFields [(Text, Text)]
fields

      case [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
missing of
        Int
0 -> do
          let newM :: Migration
newM = Text -> Migration
emptyMigration Text
name
          case Migration -> [(Text, Text)] -> Maybe Migration
migrationFromFields Migration
newM [(Text, Text)]
fields of
            Maybe Migration
Nothing -> FilePath -> IO Migration
forall a. FilePath -> a
throwFS (FilePath -> IO Migration) -> FilePath -> IO Migration
forall a b. (a -> b) -> a -> b
$ FilePath
"Error in " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
forall a. Show a => a -> FilePath
show FilePath
path) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": unrecognized field found"
            Just Migration
m -> Migration -> IO Migration
forall (m :: * -> *) a. Monad m => a -> m a
return Migration
m
        Int
_ -> FilePath -> IO Migration
forall a. FilePath -> a
throwFS (FilePath -> IO Migration) -> FilePath -> IO Migration
forall a b. (a -> b) -> a -> b
$ FilePath
"Error in " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
forall a. Show a => a -> FilePath
show FilePath
path) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": missing required field(s): " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
missing)

getFields :: J.Object -> [(Text, Text)]
getFields :: HashMap Text Value -> [(Text, Text)]
getFields HashMap Text Value
mp = ((Text, Value) -> (Text, Text))
-> [(Text, Value)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Value) -> (Text, Text)
toPair ([(Text, Value)] -> [(Text, Text)])
-> [(Text, Value)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Text Value
mp
    where
      toPair :: (Text, Value) -> (Text, Text)
      toPair :: (Text, Value) -> (Text, Text)
toPair (Text
k, J.String Text
v) = (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
k, Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
v)
      toPair (Text
k, Value
J.Null) = (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
k, FilePath -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (FilePath
"" :: String))
      toPair (Text
k, Value
v) = FilePath -> (Text, Text)
forall a. FilePath -> a
throwFS (FilePath -> (Text, Text)) -> FilePath -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ FilePath
"Error in YAML input; expected string key and string value, got " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Text, Value) -> FilePath
forall a. Show a => a -> FilePath
show (Text
k, Value
v))
getFields HashMap Text Value
_ = FilePath -> [(Text, Text)]
forall a. FilePath -> a
throwFS FilePath
"Error in YAML input; expected mapping"

missingFields :: [(Text, Text)] -> [Text]
missingFields :: [(Text, Text)] -> [Text]
missingFields [(Text, Text)]
fs =
    [ Text
k | Text
k <- [Text]
requiredFields, Bool -> Bool
not (Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
inputStrings) ]
    where
      inputStrings :: [Text]
inputStrings = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst [(Text, Text)]
fs

-- |Given a migration and a list of parsed migration fields, update
-- the migration from the field values for recognized fields.
migrationFromFields :: Migration -> [(Text, Text)] -> Maybe Migration
migrationFromFields :: Migration -> [(Text, Text)] -> Maybe Migration
migrationFromFields Migration
m [] = Migration -> Maybe Migration
forall a. a -> Maybe a
Just Migration
m
migrationFromFields Migration
m ((Text
name, Text
value):[(Text, Text)]
rest) = do
  FieldProcessor
processor <- Text -> [(Text, FieldProcessor)] -> Maybe FieldProcessor
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(Text, FieldProcessor)]
fieldProcessors
  Migration
newM <- FieldProcessor
processor Text
value Migration
m
  Migration -> [(Text, Text)] -> Maybe Migration
migrationFromFields Migration
newM [(Text, Text)]
rest

requiredFields :: [Text]
requiredFields :: [Text]
requiredFields = [ Text
"Apply"
                 , Text
"Depends"
                 ]

fieldProcessors :: [(Text, FieldProcessor)]
fieldProcessors :: [(Text, FieldProcessor)]
fieldProcessors = [ (Text
"Created", FieldProcessor
setTimestamp )
                  , (Text
"Description", FieldProcessor
setDescription )
                  , (Text
"Apply", FieldProcessor
setApply )
                  , (Text
"Revert", FieldProcessor
setRevert )
                  , (Text
"Depends", FieldProcessor
setDepends )
                  ]

setTimestamp :: FieldProcessor
setTimestamp :: FieldProcessor
setTimestamp Text
value Migration
m = do
  UTCTime
ts <- case Text -> [(UTCTime, FilePath)]
readTimestamp Text
value of
          [(UTCTime
t, FilePath
_)] -> UTCTime -> Maybe UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
          [(UTCTime, FilePath)]
_ -> FilePath -> Maybe UTCTime
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"expected one valid parse"
  Migration -> Maybe Migration
forall (m :: * -> *) a. Monad m => a -> m a
return (Migration -> Maybe Migration) -> Migration -> Maybe Migration
forall a b. (a -> b) -> a -> b
$ Migration
m { mTimestamp :: Maybe UTCTime
mTimestamp = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
ts }

readTimestamp :: Text -> [(UTCTime, String)]
readTimestamp :: Text -> [(UTCTime, FilePath)]
readTimestamp = ReadS UTCTime
forall a. Read a => ReadS a
reads ReadS UTCTime
-> (Text -> FilePath) -> Text -> [(UTCTime, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs

setDescription :: FieldProcessor
setDescription :: FieldProcessor
setDescription Text
desc Migration
m = Migration -> Maybe Migration
forall a. a -> Maybe a
Just (Migration -> Maybe Migration) -> Migration -> Maybe Migration
forall a b. (a -> b) -> a -> b
$ Migration
m { mDesc :: Maybe Text
mDesc = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
desc }

setApply :: FieldProcessor
setApply :: FieldProcessor
setApply Text
apply Migration
m = Migration -> Maybe Migration
forall a. a -> Maybe a
Just (Migration -> Maybe Migration) -> Migration -> Maybe Migration
forall a b. (a -> b) -> a -> b
$ Migration
m { mApply :: Text
mApply = Text
apply }

setRevert :: FieldProcessor
setRevert :: FieldProcessor
setRevert Text
revert Migration
m = Migration -> Maybe Migration
forall a. a -> Maybe a
Just (Migration -> Maybe Migration) -> Migration -> Maybe Migration
forall a b. (a -> b) -> a -> b
$ Migration
m { mRevert :: Maybe Text
mRevert = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
revert }

setDepends :: FieldProcessor
setDepends :: FieldProcessor
setDepends Text
depString Migration
m = Migration -> Maybe Migration
forall a. a -> Maybe a
Just (Migration -> Maybe Migration) -> Migration -> Maybe Migration
forall a b. (a -> b) -> a -> b
$ Migration
m { mDeps :: [Text]
mDeps = Text -> [Text]
T.words Text
depString }