Util.hs

module DarcsDen.State.Util where

import Control.Monad
import Control.Monad.Trans
import Data.Time (UTCTime, readTime)
import System.Directory
import System.FilePath
import System.Locale (defaultTimeLocale)
import Database.CouchDB
import Database.Redis.Monad.State (RedisM, runWithRedis)
import Database.Redis.Monad (flushAll)
import Text.JSON
import qualified Database.Redis.Redis as R

import DarcsDen.Settings
import DarcsDen.State.Schema


runDB :: CouchMonad a -> IO a
runDB = runCouchDB couchHost couchPort

withRedis :: (MonadIO m) => RedisM a -> m a
withRedis a = liftIO $ do
    c <- R.connect redisHost redisPort
    runWithRedis c a

getDocByView :: (JSON a, JSON b) => DB -> Doc -> Doc -> a -> CouchMonad (Maybe b)
getDocByView db' design view key = do
    get <- queryView db' design view [("key", showJSON key)]
    case get of
         [] -> return Nothing
         ((_, val):_) -> return (Just val)

-- . is allowed in repo names except at the beginning,
-- for this to be safe / and \ must remain disallowed.
charIsSane :: Char -> Bool
charIsSane = flip elem (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_.")

isSane :: String -> Bool
isSane ('.':_) = False
isSane s       = all charIsSane s

saneName :: String -> String
saneName = filter charIsSane

userDir :: String -> FilePath
userDir un = usersDir </> saneName un

repoDir :: String -> String -> FilePath
repoDir un rn = userDir un </> saneName rn

getAttr :: JSON a => JSValue -> String -> Result a
getAttr (JSObject o) n =
    maybe
        (fail ("object missing `" ++ n ++ "': " ++ show o))
        readJSON
        (lookup n (fromJSObject o))
getAttr js n =
    fail ("not an object (needed `" ++ n ++ "' attribute): " ++ show js)

getAttrOr :: JSON a => JSValue -> String -> a -> Result a
getAttrOr (JSObject o) n d =
    maybe (return d) readJSON (lookup n (fromJSObject o))
getAttrOr js n _ =
    fail ("not an object (needed `" ++ n ++ "' attribute): " ++ show js)

getOneOf :: JSON a => JSValue -> String -> String -> Result a
getOneOf (JSObject o) a b =
    maybe (getAttr (JSObject o) b) readJSON (lookup a (fromJSObject o))
getOneOf js n _ =
    fail ("not an object (needed `" ++ n ++ "' attribute): " ++ show js)

getTime :: JSValue -> String -> Result UTCTime
getTime o n = fmap (readTime defaultTimeLocale "%F %T") (getAttr o n)

getMaybeTime :: JSValue -> String -> Result (Maybe UTCTime)
getMaybeTime o n =
   (getAttrOr o n Nothing :: Result (Maybe String)) >>=
   ((return.fmap (readTime defaultTimeLocale "%F %T")) :: Maybe String -> Result (Maybe UTCTime))

getID :: JSValue -> Result Doc
getID o = getAttr o "_id"

getRev :: JSValue -> Result Rev
getRev o = fmap rev (getAttr o "_rev")

resetAllState :: MonadIO m => m ()
resetAllState = do
    withRedis flushAll
    liftIO $ do
        runDB $ do
	    mapM_ dropDB ["repositories", "users", "issues", "comments"]
            createFreshState False
	doesDirectoryExist usersDir >>= flip when (removeDirectoryRecursive usersDir)

createFreshState :: Bool -> CouchMonad ()
createFreshState verbose = do
    when verbose $ liftIO (putStrLn "creating databases...")
    createDB "repositories"
    createDB "users"
    createDB "issues"
    createDB "comments"

    when verbose $ liftIO (putStrLn "creating repository design documents...")
    forM_ repoDesigns $ \js ->
        newDoc (db "repositories") js

    when verbose $ liftIO (putStrLn "creating user design documents...")
    forM_ userDesigns $ \js ->
        newDoc (db "users") js

    when verbose $ liftIO (putStrLn "creating issue design documents...")
    forM_ issueDesigns $ \js ->
        newDoc (db "issues") js

    when verbose $ liftIO (putStrLn "creating comment design documents...")
    forM_ commentDesigns $ \js ->
        newDoc (db "comments") js

    when verbose $ liftIO (putStrLn "All set!")