dirfiles-0.1.0.2: Data/Library.hs
{-# LANGUAGE OverloadedStrings,TemplateHaskell, BangPatterns #-}
module Data.Library
( Library
, ItemId
, LibraryItem(..)
, Error(..)
, move
, copy
, delete
, rename
, describe
, touch
, new
, unsafeGetItem
, getItem
-- , testItems
)
where
import Data.Text (Text)
import Data.IntSet (IntSet, insert, empty)
import qualified Data.IntSet as IS
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq
import Data.Time.Clock (UTCTime)
import Data.Library.UUIRI (UUIRI, iri, uuid, toUUIRI)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Data.SafeCopy (deriveSafeCopy, base)
import Data.Maybe (fromMaybe)
import Data.Aeson ( ToJSON(toJSON), FromJSON(parseJSON), object
, (.=), (.:), (.:?), Value(Object, Null))
import Data.Indexation.UUID hiding (fromText)
import Data.Indexation.Constraints (Text256, Text4096, fromText)
-- | 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 $ fromText 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 $ fromText 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) (fromText name) (fmap fromText description)
creationTime creationTime parent $
maybe (Left $ Dir 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 (Dir files dirs) -> Right $
if isDir item
then dir { itemDateModified = t
, itemType = Left $ Dir files (op (itemId item) dirs)
}
else dir { itemDateModified = t
, itemType = Left $ Dir (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 :: !Text256
, itemDescription :: !(Maybe Text4096) -- short description
, itemDateCreated :: !UTCTime
, itemDateModified :: !UTCTime
, itemParent :: !ItemId -- root dir has parent = 0
, itemType :: !(Either Directory UUIRI)
}
{-
testItems t =
[ Item 0 "teste" (Just "isto eh um teste") t t 0 (Left (IS.singleton 1,IS.singleton 2))
, f1 t, d1 t
]
f1 t = Item 1 "f1" (Just "ficheiro 1") t t 0 (Right $ toUUIRI (UUID $ fromWords 1 2 3 4) "http://blah.com/f1.txt")
d1 t = Item 2 "d1" (Just "dir 1") t t 0 (Left (empty, empty))
-}
instance ToJSON LibraryItem where
toJSON Deleted = Null
toJSON (Item iid iname idesc icreated imodified iparent itype) = object $
case itype of
Right f -> ("uuid", toJSON (uuid f)) : ("url", toJSON (iri f)) :
("subdirectories", Null) : ("files",Null) : common
Left (Dir f d) ->
("uuid", Null) : ("url", Null) :
("subdirectories", toJSON d) : ("files", toJSON f) :
common
where
common = ["id" .= iid, "name" .= iname, "description" .= idesc
, "created" .= icreated, "modified" .= imodified
, "parent" .= iparent
]
instance FromJSON LibraryItem where
parseJSON Null = return Deleted
parseJSON (Object i) = Item <$> i .: "id"
<*> i .: "name"
<*> i .: "description"
<*> i .: "created"
<*> i .: "modified"
<*> i .: "parent"
<*> do fuuid <- i .:? "uuid"
furl <- i .:? "url"
dfiles <- i .:? "files"
ddirs <- i .:? "subdirectories"
return $ case furl of
Nothing -> makeDir dfiles ddirs
Just f -> makeUUIRI fuuid f
where
makeDir :: Maybe IntSet -> Maybe IntSet -> Either Directory UUIRI
makeDir i1 i2 = Left $ Dir (fromMaybe (IS.empty) i1)
(fromMaybe (IS.empty) i2)
makeUUIRI :: Maybe UUID -> Text -> Either Directory UUIRI
makeUUIRI u iri' = Right $ toUUIRI (fromMaybe nil u) iri'
parseJSON _ = mzero
isDir :: LibraryItem -> Bool
isDir i = case itemType i of
Right _ -> True
_ -> False
-- | A directory is just a pair of IntSet's where the first one has the
-- files, and the second has the subdirectories
data Directory = Dir !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 ''Directory)
$(deriveSafeCopy 0 'base ''LibraryItem)