dirfiles-0.1.0.0: Data/Library.hs

{-# LANGUAGE OverloadedStrings,TemplateHaskell #-}
module Data.Library 
( Library
, ItemId
, LibraryItem(..)
, Error(..)
, move
, copy
, delete
, rename
, describe
, touch
, new
, unsafeGetItem
, getItem
-- , testItem
)

where
import Data.Text (Text)
import Data.IntSet (IntSet, insert, empty)
import qualified Data.IntSet as IS
import Data.Sequence (Seq, adjust, (|>))
import qualified Data.Sequence as Seq
import Data.Time.Clock (UTCTime)
import Data.Library.UUIRI (UUIRI)
import Data.Foldable (toList)
import Data.Aeson (ToJSON(toJSON), FromJSON(parseJSON), object, (.=), (.:), Value(Object, Null))
import Data.Aeson.Types (Parser)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import qualified Data.HashMap.Strict as HM
import Data.SafeCopy (deriveSafeCopy, base)

-- | A Library is just a rebranded Seq
type Library = Seq LibraryItem


type ItemId = Int

move :: Library -> ItemId -> ItemId -> UTCTime -> Either Error Library 
move lib origin destination t = if origin == 0 then Left MovingRoot else do
    d <- getItem destination lib    -- destination
    i <- getItem origin lib         -- item
    let parentId = itemParent i
    p <- getItem parentId lib       -- parent
    ud <- addItemInDir i d t        -- updated destination
    up <- rmItemFromDir i p t       -- updated parent
    return $ Seq.update destination ud 
           $ Seq.update parentId up 
           $ Seq.adjust (\item -> item { itemDateModified = t }) origin lib

copy :: Library -> ItemId -> ItemId -> UTCTime -> Either Error Library
copy lib origin destination t = do
    d <- getItem destination lib    -- destination
    i <- getItem origin lib         -- item
    let newParentId = itemId d
        newItem = i { itemDateModified = t
                    , itemId = Seq.length lib
                    , itemParent = newParentId }
    ud <- addItemInDir newItem d t  -- add the copy to the destination
    return $ Seq.update newParentId ud (lib |> newItem)

delete :: Library -> ItemId -> Library
delete lib target = Seq.update target Deleted lib

-- | Changes the name of an item
rename :: Library -> ItemId -> Text -> UTCTime -> Library
rename lib target name t = Seq.adjust (setName t name) target lib
    where
        setName t' n i = i { itemDateModified = t', itemName = n }

-- | Sets the description of an item 
describe :: Library -> ItemId -> Text -> UTCTime -> Library
describe lib target description t = 
    Seq.adjust (setDescription t description) target lib
    where
        setDescription t' d i = i { itemDateModified = t'
                                  , itemDescription = Just d }

-- | Sets the modified date of an item to the one supplied in arg t
touch :: Library -> ItemId -> UTCTime -> Library
touch lib target t = Seq.adjust (setTime t) target lib
    where
        setTime t i = i { itemDateModified = t }

-- | Create a new item in the library 
-- If createing a directory then uuiri must be Nothing
new :: Text -> Maybe Text -> UTCTime -> ItemId -> Maybe UUIRI -> Library 
    -> Either Error Library
new name description creationTime parent uuiri lib = do
    p <- getItem parent lib             -- parent directory
    up <- addItemInDir i p creationTime -- updated parent
    return $ Seq.update parent up       -- updates the library with it
           $ lib |> i                   -- adds the new item to the library
    where
        i = Item (Seq.length lib) name description creationTime creationTime 
                 parent $ maybe (Left (empty, empty)) Right uuiri

-- | No bounds checking and doesn't filter deleted items
-- returns an exception error when the item is not found
unsafeGetItem :: ItemId -> Library -> LibraryItem
unsafeGetItem = flip Seq.index 

-- | Does bounds checking and also checks if the item was not deleted
getItem :: ItemId -> Library -> Either Error LibraryItem
getItem i l = if i >= Seq.length l 
                then Left $ ItemNotFound i
                else let item = Seq.index l i 
                     in case item of 
                            Deleted -> Left $ ItemNotFound i
                            _ -> Right item
--- // ---
-- HELPERS
itemOpInDir :: (Int -> IntSet -> IntSet) -> LibraryItem -> LibraryItem 
            -> UTCTime -> Either Error LibraryItem
itemOpInDir op item dir t = 
    case itemType dir of
        Right _ -> Left $ InvalidDestination (itemId dir)
        Left (files, dirs) -> Right $ 
            if isDir item 
                then dir { itemDateModified = t
                         , itemType = Left (files, op (itemId item) dirs) 
                         }
                else dir { itemDateModified = t
                         , itemType = Left (op (itemId item) files, dirs) 
                         }

addItemInDir :: LibraryItem -> LibraryItem -> UTCTime 
             -> Either Error LibraryItem
addItemInDir = itemOpInDir insert 

rmItemFromDir :: LibraryItem -> LibraryItem -> UTCTime 
              -> Either Error LibraryItem
rmItemFromDir = itemOpInDir IS.delete
-- HELPERS
--- // ---

-- | An item in the library
data LibraryItem = 
    Deleted | 
    Item 
    { itemId           :: ItemId -- root dir is 0
    , itemName         :: Text
    , itemDescription  :: Maybe Text -- short description
    , itemDateCreated  :: UTCTime
    , itemDateModified :: UTCTime
    , itemParent       :: ItemId -- root dir has parent = 0
    , itemType         :: Either Directory UUIRI
    } 


-- testItem t = Item 0 "teste" (Just "isto é um teste") t t 0 (Left (empty,empty))

instance ToJSON LibraryItem where
    toJSON Deleted = Null
    toJSON (Item iid iname idesc icreated imodified iparent itype) = 
       object ["id" .= iid, "name" .= iname, "description" .= idesc
              , "created" .= icreated, "modified" .= imodified
              , "parent" .= iparent, "item" .= typeJson
              ] 
        where 
            typeJson = case itype of
                        Left (f,d) -> object [ "files" .= f 
                                             , "subdirectories" .= d
                                             ]
                        Right f -> toJSON f

instance FromJSON LibraryItem where
    parseJSON Null = return Deleted
    parseJSON (Object i) = Item <$> i .: "id" 
                                <*> i .: "name"
                                <*> i .: "description"
                                <*> i .: "created"
                                <*> i .: "modified"
                                <*> i .: "parent"
                                <*> lookForItem i
        where 
              -- WARNING: HM.lookup might change if aeson changes the type 
              lookForItem i = maybe emptyDir getType $ HM.lookup "item" i 
              getType t = case t of 
                            Object o -> toDirectory <$> o .: "files"
                                                    <*> o .: "subdirectories"
                            _ -> Right <$> parseJSON t
              toDirectory :: IntSet -> IntSet -> Either Directory UUIRI
              toDirectory f d = Left (f,d)
              emptyDir = return $ Left (empty, empty)
    parseJSON _          = mzero

isDir :: LibraryItem -> Bool
isDir i = case itemType i of 
            Right _ -> True
            _ -> False

-- | A directory is just a tuple of IntSet's where the first one has the
-- files, and the second has the subdirectories 
type Directory = (IntSet, IntSet) 


-- | Some errors that might occur
data Error = InvalidDestination ItemId
           | ItemNotFound ItemId
           | MovingRoot
instance Show Error where
    show (InvalidDestination i) = "Invalid destination with id " ++ (show i)
    show (ItemNotFound i) = "Item with id " ++ (show i) ++ " not found"
    show MovingRoot = "Cannot move root directory"
{-
newFileTextIO :: Text -> Text -> IO FileText
newFileTextIO n c = do
    t <- getCurrentTime
    return $ newFileText n t c
-}

deriveSafeCopy 0 'base ''LibraryItem