dbmigrations 0.1 → 0.1.1

raw patch · 4 files changed

+215/−1 lines, 4 files

Files

dbmigrations.cabal +6/−1
src/Database/Schema/Migrations/CycleDetection.hs +64/−0
src/Database/Schema/Migrations/Filesystem/Parse.hs +76/−0
src/Database/Schema/Migrations/Filesystem/Serialize.hs +69/−0

dbmigrations.cabal view

@@ -1,5 +1,5 @@ Name:                dbmigrations-Version:             0.1+Version:             0.1.1 Synopsis:            An implementation of relational database "migrations" Description:         A library and program for the creation,                      management, and installation of schema updates@@ -59,6 +59,11 @@           Database.Schema.Migrations.Backend           Database.Schema.Migrations.Backend.HDBC           Database.Schema.Migrations.Store++  Other-Modules:+          Database.Schema.Migrations.CycleDetection+          Database.Schema.Migrations.Filesystem.Parse+          Database.Schema.Migrations.Filesystem.Serialize  Executable test   Build-Depends:

+ src/Database/Schema/Migrations/CycleDetection.hs view

@@ -0,0 +1,64 @@+module Database.Schema.Migrations.CycleDetection+    ( hasCycle+    )+where++import Data.Graph.Inductive.Graph+    ( Graph(..)+    , Node+    , nodes+    , edges+    )++import Control.Monad.State ( State, evalState, gets, get, put )+import Control.Monad ( forM )++import Data.Maybe ( fromJust )+import Data.List ( findIndex )++data Mark = White | Gray | Black+type CycleDetectionState = [(Node, Mark)]++-- Cycle detection algorithm taken from http://www.cs.berkeley.edu/~kamil/teaching/sp03/041403.pdf+hasCycle :: Graph g => g a b -> Bool+hasCycle g = evalState (hasCycle' g) [(n, White) | n <- nodes g]++getMark :: Int -> State CycleDetectionState Mark+getMark n = gets (fromJust . lookup n) >>= return++replace :: [a] -> Int -> a -> [a]+replace elems index val+    | index > length elems = error "replacement index too large"+    | otherwise = (take index elems) +++                  [val] +++                  (reverse $ take ((length elems) - (index + 1)) $ reverse elems)++setMark :: Int -> Mark -> State CycleDetectionState ()+setMark n mark = do+  st <- get+  let index = fromJust $ findIndex (\(n', _) -> n' == n) st+  put $ replace st index (n, mark)++hasCycle' :: Graph g => g a b -> State CycleDetectionState Bool+hasCycle' g = do+  result <- forM (nodes g) $ \n -> do+                   m <- getMark n+                   case m of+                     White -> visit g n+                     _ -> return False+  return $ or result++visit :: Graph g => g a b -> Node -> State CycleDetectionState Bool+visit g n = do+  setMark n Gray+  result <- forM [ v | (u,v) <- edges g, u == n ] $ \node -> do+              m <- getMark node+              case m of+                Gray -> return True+                White -> visit g node+                _ -> return False+  case or result of+    True -> return True+    False -> do+              setMark n Black+              return False

+ src/Database/Schema/Migrations/Filesystem/Parse.hs view

@@ -0,0 +1,76 @@+module Database.Schema.Migrations.Filesystem.Parse+    ( migrationParser+    , parseDepsList+    , FieldName+    , Field+    , FieldSet+    )+where++import Data.Time.Clock ()+import Data.Maybe ( catMaybes )++import Text.ParserCombinators.Parsec++type FieldName = String+type Field = (FieldName, String)+type FieldSet = [Field]++-- |Parse a migration document and return a list of parsed fields and+-- a list of claimed dependencies.+migrationParser :: Parser [Field]+migrationParser = do+  result <- many (parseField <|> parseComment <|> parseEmptyLine)+  return $ catMaybes result++parseDepsList :: Parser [String]+parseDepsList =+    let parseMID = many1 (alphaNum <|> oneOf "-._")+    in do+      deps <- sepBy parseMID whitespace+      eol+      return deps++discard :: Parser a -> Parser ()+discard = (>> return ())++eol :: Parser ()+eol = (discard newline) <|> (discard eof)++whitespace :: Parser Char+whitespace = oneOf " \t"++requiredWhitespace :: Parser String+requiredWhitespace = many1 whitespace++parseFieldName :: Parser FieldName+parseFieldName = many1 (alphaNum <|> char '-')++parseComment :: Parser (Maybe Field)+parseComment = do+  discard $ do+    many whitespace+    char '#'+    manyTill anyChar eol+  return Nothing++parseEmptyLine :: Parser (Maybe Field)+parseEmptyLine = newline >> return Nothing++parseField :: Parser (Maybe Field)+parseField = do+  name <- parseFieldName+  char ':'+  many whitespace+  rest <- manyTill anyChar eol+  otherLines <- otherContentLines+  let value = rest ++ (concat otherLines)+  return $ Just (name, value)++otherContentLines :: Parser [String]+otherContentLines =+    many $ try $ (discard newline >> return "") <|> do+      ws <- requiredWhitespace+      rest <- manyTill anyChar eol+      -- Retain leading whitespace and trailing newline+      return $ ws ++ rest ++ "\n"

+ src/Database/Schema/Migrations/Filesystem/Serialize.hs view

@@ -0,0 +1,69 @@+module Database.Schema.Migrations.Filesystem.Serialize+    ( serializeMigration+    )+where++import Data.Time () -- for UTCTime Show instance+import Data.Maybe ( catMaybes )+import Data.List ( intercalate )++import Database.Schema.Migrations.Migration+    ( Migration(..)+    )++type FieldSerializer = Migration -> Maybe String++fieldSerializers :: [FieldSerializer]+fieldSerializers = [ serializeDesc+                   , serializeTimestamp+                   , serializeDepends+                   , serializeApply+                   , serializeRevert+                   ]++serializeDesc :: FieldSerializer+serializeDesc m =+    case mDesc m of+      Nothing -> Nothing+      Just desc -> Just $ "Description: " ++ desc++serializeTimestamp :: FieldSerializer+serializeTimestamp m = Just $ "Created: " ++ (show $ mTimestamp m)++serializeDepends :: FieldSerializer+serializeDepends m = Just $ "Depends: " ++ (intercalate " " $ mDeps m)++serializeRevert :: FieldSerializer+serializeRevert m =+    case mRevert m of+      Nothing -> Nothing+      Just revert -> Just $ "Revert:\n" +++                     (serializeMultiline revert)++serializeApply :: FieldSerializer+serializeApply m = Just $ "Apply:\n" ++ (serializeMultiline $ mApply m)++commonPrefix :: String -> String -> String+commonPrefix a b = map fst $ takeWhile (uncurry (==)) (zip a b)++commonPrefixLines :: [String] -> String+commonPrefixLines [] = ""+commonPrefixLines theLines = foldl1 commonPrefix theLines++serializeMultiline :: String -> String+serializeMultiline s =+    let sLines = lines s+        prefix = case commonPrefixLines sLines of+                   -- If the lines already have a common prefix that+                   -- begins with whitespace, no new prefix is+                   -- necessary.+                   (' ':_) -> ""+                   -- Otherwise, use a new prefix of two spaces.+                   _ -> "  "++    in unlines $ map (prefix ++) sLines++serializeMigration :: Migration -> String+serializeMigration m = intercalate "\n" fields+    where+      fields = catMaybes [ f m | f <- fieldSerializers ]