Merge pull request jtdaugherty#43 from pbrisbin/pb/from-json

Rewrite Migration parser using conventional FromJSON

dbmigrations.cabal

@@ -86,7 +86,7 @@ Library
     configurator >= 0.2,
     split >= 0.2.2,
     HUnit >= 1.2,
-    aeson < 2,
+    aeson,
     unordered-containers
 
   Hs-Source-Dirs:    src

src/Database/Schema/Migrations/Filesystem.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables, OverloadedStrings #-}
 -- |This module provides a type for interacting with a
 -- filesystem-backed 'MigrationStore'.
 module Database.Schema.Migrations.Filesystem
@@ -20,26 +20,21 @@ import Data.String.Conversions ( cs, (<>) )
 
 import Data.Typeable ( Typeable )
 import Data.Time.Clock ( UTCTime )
-import Data.Time () -- for UTCTime Show instance
+import Data.Time ( defaultTimeLocale, formatTime, parseTimeM )
 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 Data.Aeson
+import Data.Aeson.Types (typeMismatch)
+import qualified Data.Yaml as Yaml
+import GHC.Generics (Generic)
 
-import Database.Schema.Migrations.Migration
-    ( Migration(..)
-    , emptyMigration
-    )
+import Database.Schema.Migrations.Migration (Migration(..))
 import Database.Schema.Migrations.Filesystem.Serialize
 import Database.Schema.Migrations.Store
 
-type FieldProcessor = Text -> Migration -> Maybe Migration
-
 data FilesystemStoreSettings = FSStore { storePath :: FilePath }
 
 data FilesystemStoreError = FilesystemStoreError String
@@ -106,79 +101,77 @@ migrationFromPath path = do
     readMigrationFile = do
       ymlExists <- doesFileExist (addNewMigrationExtension path)
       if ymlExists
-        then decodeFileThrow (addNewMigrationExtension path) `catch` (\(e::ParseException) -> throwFS $ show e)
-        else decodeFileThrow (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::ParseException) -> throwFS $ show e)
-
-    process name = do
-      yaml <- readMigrationFile
-
-      -- Convert yaml structure into basic key/value map
-      let fields = getFields yaml
-          missing = missingFields fields
-
-      case length missing of
-        0 -> do
-          let newM = emptyMigration name
-          case migrationFromFields newM fields of
-            Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found"
-            Just m -> return m
-        _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing)
-
-getFields :: J.Object -> [(Text, Text)]
-getFields mp = map toPair $ M.toList mp
-    where
-      toPair :: (Text, Value) -> (Text, Text)
-      toPair (k, J.String v) = (cs k, cs v)
-      toPair (k, J.Null) = (cs k, cs ("" :: String))
-      toPair (k, v) = throwFS $ "Error in YAML input; expected string key and string value, got " ++ (show (k, v))
-getFields _ = throwFS "Error in YAML input; expected mapping"
-
-missingFields :: [(Text, Text)] -> [Text]
-missingFields fs =
-    [ k | k <- requiredFields, not (k `elem` inputStrings) ]
-    where
-      inputStrings = map fst 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 m [] = Just m
-migrationFromFields m ((name, value):rest) = do
-  processor <- lookup name fieldProcessors
-  newM <- processor value m
-  migrationFromFields newM rest
-
-requiredFields :: [Text]
-requiredFields = [ "Apply"
-                 , "Depends"
-                 ]
-
-fieldProcessors :: [(Text, FieldProcessor)]
-fieldProcessors = [ ("Created", setTimestamp )
-                  , ("Description", setDescription )
-                  , ("Apply", setApply )
-                  , ("Revert", setRevert )
-                  , ("Depends", setDepends )
-                  ]
-
-setTimestamp :: FieldProcessor
-setTimestamp value m = do
-  ts <- case readTimestamp value of
-          [(t, _)] -> return t
-          _ -> fail "expected one valid parse"
-  return $ m { mTimestamp = Just ts }
-
-readTimestamp :: Text -> [(UTCTime, String)]
-readTimestamp = reads . cs
-
-setDescription :: FieldProcessor
-setDescription desc m = Just $ m { mDesc = Just desc }
-
-setApply :: FieldProcessor
-setApply apply m = Just $ m { mApply = apply }
-
-setRevert :: FieldProcessor
-setRevert revert m = Just $ m { mRevert = Just revert }
-
-setDepends :: FieldProcessor
-setDepends depString m = Just $ m { mDeps = T.words depString }
+        then Yaml.decodeFileThrow (addNewMigrationExtension path) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e)
+        else Yaml.decodeFileThrow (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e)
+
+    process name = migrationYamlToMigration name <$> readMigrationFile
+
+-- | TODO: re-use this for the generation side too
+data MigrationYaml = MigrationYaml
+    { myCreated :: Maybe UTCTimeYaml
+    , myDescription :: Maybe Text
+    , myApply :: Text
+    , myRevert :: Maybe Text
+    , myDepends :: DependsYaml
+    }
+    deriving Generic
+
+instance FromJSON MigrationYaml where
+    parseJSON = genericParseJSON jsonOptions
+
+instance ToJSON MigrationYaml where
+    toJSON = genericToJSON jsonOptions
+    toEncoding = genericToEncoding jsonOptions
+
+jsonOptions :: Options
+jsonOptions = defaultOptions
+    { fieldLabelModifier = drop 2 -- remove "my" prefix
+    , omitNothingFields = True
+    , rejectUnknownFields = True
+    }
+
+migrationYamlToMigration :: Text -> MigrationYaml -> Migration
+migrationYamlToMigration theId my = Migration
+    { mTimestamp = unUTCTimeYaml <$> myCreated my
+    , mId = theId
+    , mDesc = myDescription my
+    , mApply = myApply my
+    , mRevert = myRevert my
+    , mDeps = unDependsYaml $ myDepends my
+    }
+
+newtype UTCTimeYaml = UTCTimeYaml
+    { unUTCTimeYaml :: UTCTime
+    }
+
+instance FromJSON UTCTimeYaml where
+    parseJSON = withText "UTCTime"
+        $ maybe (fail "Unable to parse UTCTime") (pure . UTCTimeYaml)
+        . parseTimeM True defaultTimeLocale utcTimeYamlFormat
+        . cs
+
+instance ToJSON UTCTimeYaml where
+    toJSON = toJSON . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml
+    toEncoding = toEncoding . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml
+
+-- Keeps things as the old Show/Read-based format, e.g "2009-04-15 10:02:06 UTC"
+utcTimeYamlFormat :: String
+utcTimeYamlFormat = "%F %T UTC"
+
+newtype DependsYaml = DependsYaml
+    { unDependsYaml :: [Text]
+    }
+
+instance FromJSON DependsYaml where
+    parseJSON = \case
+        Null -> pure $ DependsYaml []
+        String t -> pure $ DependsYaml $ T.words t
+        x -> typeMismatch "Null or whitespace-separated String" x
+
+instance ToJSON DependsYaml where
+    toJSON (DependsYaml ts) = case ts of
+        [] -> toJSON Null
+        _ -> toJSON $ T.unwords ts
+    toEncoding (DependsYaml ts) = case ts of
+        [] -> toEncoding Null
+        _ -> toEncoding $ T.unwords ts