Repository.hs

module DarcsDen.State.Repository where

import Control.Monad (forM_, when)
import Control.Monad.Trans
import Data.Char
import Data.Ord
import Data.List
import Data.Maybe (catMaybes, fromJust)
import Data.Time (UTCTime, formatTime)
import Database.CouchDB
import System.Directory
import System.Locale (defaultTimeLocale)
import Text.JSON

import DarcsDen.State.Util
import qualified DarcsDen.Darcs as Darcs
import DarcsDen.Settings


data Repository =
    Repository
        { rID :: Maybe Doc
        , rRev :: Maybe Rev
        , rName :: String
        , rOwner :: String
        , rDescription :: String
        , rWebsite :: String
        , rCreated :: UTCTime
        , rForkOf :: Maybe Doc
        , rMembers :: [String]
        , rIsPrivate :: Bool
        , rIssueTracker :: Bool
        , rIssueCount :: Int
        , rBuiltPacks :: Maybe UTCTime
        }
    deriving (Eq, Show)

instance JSON Repository where
    readJSON o = do
        id' <- getID o
        rev' <- getRev o
        name <- getAttr o "name"
        owner <- getAttr o "owner"
        description <- getAttrOr o "description" ""
        website <- getAttrOr o "website" ""
        created <- getTime o "created"
        forkOf <- getAttrOr o "fork_of" Nothing
        members <- getAttrOr o "members" []
        isPrivate <- getAttrOr o "is_private" False
        issueTracker <- getAttrOr o "issue_tracker" False
        issueCount <- getAttrOr o "issue_count" 0
        builtPacks <- getMaybeTime o "packs_created"
        return Repository
            { rID = Just id'
            , rRev = Just rev'
            , rName = name
            , rOwner = owner
            , rDescription = description
            , rWebsite = website
            , rCreated = created
            , rForkOf = forkOf
            , rMembers = members
            , rIsPrivate = isPrivate
            , rIssueTracker = issueTracker
            , rIssueCount = issueCount
            , rBuiltPacks = builtPacks
            }

    showJSON r = JSObject . toJSObject $
        [ ("name", showJSON (rName r))
        , ("owner", showJSON (rOwner r))
        , ("description", showJSON (rDescription r))
        , ("website", showJSON (rWebsite r))
        , ("created", showJSON (formatTime defaultTimeLocale "%F %T" (rCreated r)))
        , ("fork_of", showJSON (rForkOf r))
        , ("members", showJSON (rMembers r))
        , ("is_private", showJSON (rIsPrivate r))
        , ("issue_tracker", showJSON (rIssueTracker r))
        , ("issue_count", showJSON (rIssueCount r))
        , ("packs_created", showJSON (fmap (formatTime defaultTimeLocale "%F %T") (rBuiltPacks r)))
        ] ++ id' ++ rev'
      where
        id' =
            case rID r of
                Just id'' -> [("_id", showJSON (show id''))]
                Nothing -> []
        rev' =
            case rRev r of
                Just rev'' -> [("_rev", showJSON (show rev''))]
                Nothing -> []


repoOwnerURL :: Repository -> String
repoOwnerURL = (baseUrl ++) . rOwner

-- The named repo's url, no trailing slash.
repoURL :: Repository -> String
repoURL r = baseUrl ++ rOwner r ++ "/" ++ rName r

getRepositoryByID :: MonadIO m => Doc -> m (Maybe Repository)
getRepositoryByID key = do
    res <- liftIO $ runDB (getDoc (db "repositories") key)
    case res of
        Just (_, _, r) -> return (Just r)
        Nothing -> return Nothing

getRepository :: MonadIO m => (String, String) -> m (Maybe Repository)
getRepository = getRepositoryByOwnerAndName (doc "repositories")

getOwnerRepository :: MonadIO m => (String, String) -> m (Maybe Repository)
getOwnerRepository = getRepositoryByOwnerAndName (doc "private")

getRepositoryByOwnerAndName :: MonadIO m => Doc -> (String, String) -> m (Maybe Repository)
getRepositoryByOwnerAndName design (un, rn) =
    liftIO (runDB query)
  where
    query = getDocByView
        (db "repositories")
        design
        (doc "by_owner_and_name")
        [un, rn]

getRepositoryForks :: MonadIO m => Doc -> m [Repository]
getRepositoryForks key =
    liftIO $ fmap (map snd) (runDB query)
  where
    query = queryView
        (db "repositories")
        (doc "repositories")
        (doc "by_fork")
        [("key", showJSON key)]

getRepositories :: MonadIO m => m [Repository]
getRepositories = do
    ids <- liftIO $ runDB (getAllDocIds (db "repositories"))
    repos <- mapM getRepositoryByID ids
    return (filter (not . rIsPrivate) $ catMaybes repos)

getUserRepositories :: MonadIO m => String -> m [Repository]
getUserRepositories = getRepositoriesByOwner (doc "repositories")

getOwnerRepositories :: MonadIO m => String -> m [Repository]
getOwnerRepositories = getRepositoriesByOwner (doc "private")

getRepositoriesByOwner :: MonadIO m => Doc -> String -> m [Repository]
getRepositoriesByOwner design on =
    liftIO $
     fmap (sortBy (comparing (map toLower . rName)) . map snd)
     (runDB query)
  where
    query = queryView
        (db "repositories")
        design
        (doc "by_owner")
        [("key", showJSON on)]

addRepository :: MonadIO m => Repository -> m Repository
addRepository r = do
    (id', rev') <- liftIO $ runDB (newDoc (db "repositories") r)
    return r { rID = Just id', rRev = Just rev' }

updateRepository :: MonadIO m => Repository -> m (Maybe Repository)
updateRepository r =
    case (rID r, rRev r) of
        (Just id', Just rev') -> do
            update <-
                liftIO . runDB $ updateDoc (db "repositories") (id', rev') r
                    { rID = Nothing }
            case update of
                Just (id'', rev'') -> return $ Just r
                    { rID = Just id''
                    , rRev = Just rev''
                    }
                _ -> return Nothing
        _ -> return Nothing

deleteRepository :: MonadIO m => Repository -> m Bool
deleteRepository r =
    case (rID r, rRev r) of
        (Just id', Just rev') -> do
            -- orphan a repository's forks
            fs <- getRepositoryForks id'
            forM_ fs $ \f ->
                updateRepository f { rForkOf = Nothing }

            liftIO $ runDB (deleteDoc (db "repositories") (id', rev'))
        _ -> return False

newRepository :: MonadIO m => Repository -> m Repository
newRepository r = do
    new <- addRepository r
    Darcs.init repo
    return new
  where repo = repoDir (rOwner r) (rName r)

destroyRepository :: MonadIO m => Repository -> m Bool
destroyRepository r = do
    success <- deleteRepository r
    if success
        then do
            when (deletefiles) $
              liftIO . removeDirectoryRecursive $ repoDir (rOwner r) (rName r)
            return True
        else return False

bootstrapRepository :: MonadIO m => Repository -> String -> m Repository
bootstrapRepository r orig =  do
    Darcs.getTo orig dest
    new <- addRepository r
    return new
  where
    dest = repoDir (rOwner r) (rName r)

forkRepository :: MonadIO m => String -> String -> Repository -> m Repository
forkRepository un rn r = do
     dest <- liftIO $ mrn (0-1)
     let fork = r {
        rID = Nothing
      , rRev = Nothing
      , rOwner = un
      , rName = dest
      , rForkOf = rID r
     }
     bootstrapRepository fork orig
  where
    orig = repoDir (rOwner r) (rName r)
    mrn :: Int -> IO String
    mrn i = do
      exists <- doesDirectoryExist (repoDir un rn++thenum)
      file_exists <- doesFileExist (repoDir un rn++thenum)
      if not exists && not file_exists
        then return (rn++thenum)
        else mrn $ i+1
     where thenum = if i == -1 then "" else "_"++show i

moveRepository :: MonadIO m => (String, String) -> Repository -> m ()
moveRepository (o, n) r =
    liftIO (renameDirectory (repoDir (rOwner r) (rName r)) (repoDir o n))

renameRepository :: MonadIO m => String -> Repository -> m (Maybe Repository)
renameRepository n r = do
    update <- updateRepository (r { rName = n })
    case update of
        Just _ -> moveRepository (rOwner r, n) r >> return update
        _ -> return Nothing

removeMember :: MonadIO m => Repository -> String -> m (Maybe Repository)
removeMember r m =
    updateRepository (r { rMembers = filter (/= m) (rMembers r) })

addMember :: MonadIO m => Repository -> String -> m (Maybe Repository)
addMember r m =
    updateRepository (r { rMembers = filter (/= m) (rMembers r) ++ [m] })

isMember :: MonadIO m => String -> (String, String) -> m Bool
isMember un key = do
    repos <- liftIO $ fmap (map snd) (runDB query)
    return (key `elem` repos)
  where
    query = queryView
        (db "repositories")
        (doc "private")
        (doc "by_member")
        [("key", showJSON un)]

withParent :: MonadIO m => (Repository -> m a) -> Repository -> m (Maybe a)
withParent f r = case rForkOf r of
    Nothing -> return Nothing
    Just p  -> getRepositoryByID p >>= f . fromJust >>= return . Just