module Data.Library
( Library
, ItemId
, LibraryItem(..)
, Error(..)
, empty
, move
, copy
, delete
, rename
, describe
, touch
, new
, unsafeGetItem
, getItem
, getItemMaybe
, showError
, isDir
)
where
import Data.Text (Text, pack)
import Data.IntSet (IntSet, insert)
import qualified Data.IntSet as IS
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq
import Data.Data (Typeable)
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)
type Library = Seq LibraryItem
type ItemId = Int
empty :: UTCTime -> Library
empty t = Seq.singleton (Item 0 (fromText "/") (Just "The root directory") t t 0
$ Left $ Dir IS.empty IS.empty )
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
i <- getItem origin lib
let parentId = itemParent i
p <- getItem parentId lib
ud <- insertItemInDir i d t
up <- rmItemFromDir i p t
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
i <- getItem origin lib
let newParentId = itemId d
newItem = i { itemDateModified = t
, itemId = Seq.length lib
, itemParent = newParentId }
ud <- insertItemInDir newItem d t
return $ Seq.update newParentId ud (lib |> newItem)
delete :: Library -> ItemId -> Library
delete lib target = Seq.update target Deleted lib
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 }
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 }
touch :: Library -> ItemId -> UTCTime -> Library
touch lib target t = Seq.adjust (setTime t) target lib
where
setTime t' i = i { itemDateModified = t' }
new :: Text -> Maybe Text -> UTCTime -> ItemId -> Maybe UUIRI -> Library
-> Either Error Library
new name description creationTime parent uuiri lib = do
p <- getItem parent lib
up <- insertItemInDir i p creationTime
return $ Seq.update parent up
$ lib |> i
where
i = Item (Seq.length lib) (fromText name) (fmap fromText description)
creationTime creationTime parent $
maybe (Left $ Dir IS.empty IS.empty) Right uuiri
unsafeGetItem :: ItemId -> Library -> LibraryItem
unsafeGetItem = flip Seq.index
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
getItemMaybe :: ItemId -> Maybe Library -> Either Error LibraryItem
getItemMaybe i (Just l) = getItem i l
getItemMaybe _ Nothing = Left InvalidContainer
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
}
insertItemInDir :: LibraryItem -> LibraryItem -> UTCTime
-> Either Error LibraryItem
insertItemInDir = itemOpInDir insert
rmItemFromDir :: LibraryItem -> LibraryItem -> UTCTime
-> Either Error LibraryItem
rmItemFromDir = itemOpInDir IS.delete
data LibraryItem =
Deleted |
Item
{ itemId :: !ItemId
, itemName :: !Text256
, itemDescription :: !(Maybe Text4096)
, itemDateCreated :: !UTCTime
, itemDateModified :: !UTCTime
, itemParent :: !ItemId
, itemType :: !(Either Directory UUIRI)
} deriving (Typeable)
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
Left _ -> True
_ -> False
data Directory = Dir !IntSet !IntSet
data Error = InvalidDestination ItemId
| ItemNotFound ItemId
| InvalidContainer
| MovingRoot
deriving(Eq, Ord, Typeable)
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"
showError :: Error -> Text
showError e = pack $ show e
$(deriveSafeCopy 0 'base ''Error)
$(deriveSafeCopy 0 'base ''Directory)
$(deriveSafeCopy 0 'base ''LibraryItem)