Added experimental Dynamic representation

Codec/ActivityStream/Dynamic.hs

@@ -0,0 +1,302 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+{-|
+Module      : Codec.ActivityStream.Dynamic
+Description : A (more dynamic) interface to Activity Streams
+Copyright   : (c) Getty Ritter, 2014
+Maintainer  : gdritter@galois.com
+
+This is an interface to ActivityStreams that simply wraps an underlying
+@aeson@ Object, and exposes a set of (convenient) lenses to access the
+values inside. If an @aeson@ object is wrapped in the respective wrapper,
+it will contain the obligatory values for that type (e.g. an @Activity@
+is guaranteed to have a @published@ date.)
+-}
+
+module Codec.ActivityStream.Dynamic
+       ( Lens'
+         -- * MediaLink
+       , MediaLink
+       , mlDuration
+       , mlHeight
+       , mlWidth
+       , mlURL
+       , mlRest
+       , makeMediaLink
+         -- * Object
+       , Object
+       , oAttachments
+       , oAuthor
+       , oContent
+       , oDisplayName
+       , oDownstreamDuplicates
+       , oId
+       , oImage
+       , oObjectType
+       , oPublished
+       , oSummary
+       , oUpdated
+       , oUpstreamDuplicates
+       , oURL
+       , oRest
+       , emptyObject
+         -- * Activity
+       , Activity
+       , acActor
+       , acContent
+       , acGenerator
+       , acIcon
+       , acId
+       , acPublished
+       , acProvider
+       , acTarget
+       , acTitle
+       , acUpdated
+       , acURL
+       , acVerb
+       , acRest
+       , makeActivity
+         -- * Collection
+       , Collection
+       , cTotalItems
+       , cItems
+       , cURL
+       , cRest
+       , makeCollection
+       ) where
+
+import           Data.Aeson ( FromJSON(..)
+                            , ToJSON(..)
+                            , Result(..)
+                            , fromJSON
+                            )
+import qualified Data.Aeson as A
+import           Data.DateTime (DateTime)
+import qualified Data.HashMap.Strict as HM
+import           Data.Maybe (fromJust)
+import           Data.Text (Text)
+
+-- This way, we don't have to import lens... but we can still export lenses!
+
+newtype Const a b = Const { fromConst :: a }
+instance Functor (Const a) where fmap f (Const x) = Const x
+
+-- We need these to write get and set
+newtype Id a = Id { fromId :: a }
+instance Functor Id where fmap f (Id x) = Id (f x)
+
+-- | This is the same type alias as in @Control.Lens@, and so can be used
+--   anywhere lenses are needed.
+type Lens' a b = forall f. Functor f => (b -> f b) -> (a -> f a)
+
+get :: Lens' a b -> a -> b
+get lens a = fromConst (lens Const a)
+
+set :: Lens' a b -> b -> a -> a
+set lens x a = fromId (lens (const Id x) a)
+
+makeLens :: (a -> b) -> (b -> a -> a) -> Lens' a b
+makeLens get set f a = (`set` a) `fmap` f (get a)
+
+fromJSON' :: FromJSON a => A.Value -> Maybe a
+fromJSON' v = case fromJSON v of
+  Success a -> Just a
+  Error _   -> Nothing
+
+-- Create a lens into an Aeson object wrapper that takes and
+-- returns a Maybe value
+makeAesonLensMb :: (FromJSON v, ToJSON v)
+              => Text -> Lens' c A.Object -> Lens' c (Maybe v)
+makeAesonLensMb key fromObj = fromObj . lens
+  where lens = makeLens
+                 (\ o -> HM.lookup key o >>= fromJSON')
+                 (\ v o -> HM.insert key (toJSON (Just v)) o)
+
+
+-- Create a lens into an Aeson object wrapper
+makeAesonLens :: (FromJSON v, ToJSON v) => Text -> Lens' c A.Object -> Lens' c v
+makeAesonLens key fromObj = fromObj . lens
+  where lens = makeLens
+                 (\ o -> fromJust (HM.lookup key o >>= fromJSON'))
+                 (\ v o -> HM.insert key (toJSON v) o)
+
+data MediaLink = MediaLink { fromMediaLink :: A.Object } deriving (Eq, Show)
+
+instance FromJSON MediaLink where
+  parseJSON (A.Object o) | HM.member "url" o = return (MediaLink o)
+                       | otherwise         = fail "..."
+  parseJSON _ = fail "..."
+
+instance ToJSON MediaLink where
+  toJSON (MediaLink o) = A.Object o
+
+mlRest :: Lens' MediaLink A.Object
+mlRest = makeLens fromMediaLink (\ o' m -> m { fromMediaLink = o' })
+
+mlDuration :: Lens' MediaLink (Maybe Int)
+mlDuration = makeAesonLensMb "duration" mlRest
+
+mlHeight :: Lens' MediaLink (Maybe Int)
+mlHeight = makeAesonLensMb "height" mlRest
+
+mlWidth :: Lens' MediaLink (Maybe Int)
+mlWidth = makeAesonLensMb "width" mlRest
+
+mlURL :: Lens' MediaLink Text
+mlURL = makeAesonLens "url" mlRest
+
+-- | Create a @MediaLink@ with just a @url@ property.
+makeMediaLink :: Text -> MediaLink
+makeMediaLink url = MediaLink (HM.insert "url" (toJSON url) HM.empty)
+
+-- | Object
+
+data Object = Object { fromObject :: A.Object } deriving (Eq, Show)
+
+instance FromJSON Object where
+  parseJSON (A.Object o) = return (Object o)
+  parseJSON _            = fail "..."
+
+instance ToJSON Object where
+  toJSON (Object o) = A.Object o
+
+oRest :: Lens' Object A.Object
+oRest = makeLens fromObject (\ o' m -> m { fromObject = o' })
+
+oAttachments :: Lens' Object (Maybe [Object])
+oAttachments = makeAesonLensMb "attachments" oRest
+
+oAuthor :: Lens' Object (Maybe Object)
+oAuthor = makeAesonLensMb "author" oRest
+
+oContent :: Lens' Object (Maybe Text)
+oContent = makeAesonLensMb "content" oRest
+
+oDisplayName :: Lens' Object (Maybe Text)
+oDisplayName = makeAesonLensMb "displayName" oRest
+
+oDownstreamDuplicates :: Lens' Object (Maybe [Text])
+oDownstreamDuplicates = makeAesonLensMb "downstreamDuplicates" oRest
+
+oId :: Lens' Object (Maybe Text)
+oId = makeAesonLensMb "id" oRest
+
+oImage :: Lens' Object (Maybe MediaLink)
+oImage = makeAesonLensMb "image" oRest
+
+oObjectType :: (FromJSON o, ToJSON o) => Lens' Object (Maybe o)
+oObjectType = makeAesonLensMb "objectType" oRest
+
+oPublished :: Lens' Object (Maybe DateTime)
+oPublished = makeAesonLensMb "published" oRest
+
+oSummary :: Lens' Object (Maybe Text)
+oSummary = makeAesonLensMb "summary" oRest
+
+oUpdated :: Lens' Object (Maybe DateTime)
+oUpdated = makeAesonLensMb "updated" oRest
+
+oUpstreamDuplicates :: Lens' Object (Maybe [Text])
+oUpstreamDuplicates = makeAesonLensMb "upstreamDuplicates" oRest
+
+oURL :: Lens' Object (Maybe Text)
+oURL = makeAesonLensMb "url" oRest
+
+-- | Create an @Object@ with no fields.
+emptyObject :: Object
+emptyObject = Object HM.empty
+
+-- | Activity
+
+data Activity = Activity { fromActivity :: A.Object } deriving (Eq, Show)
+
+instance FromJSON Activity where
+  parseJSON (A.Object o)
+    | HM.member "published" o && HM.member "provider" o = return (Activity o)
+    | otherwise = fail "..."
+  parseJSON _ = fail "..."
+
+instance ToJSON Activity where
+  toJSON (Activity o) = A.Object o
+
+acRest :: Lens' Activity A.Object
+acRest = makeLens fromActivity (\ o' m -> m { fromActivity = o' })
+
+acActor :: Lens' Activity Object
+acActor = makeAesonLens "actor" acRest
+
+acContent :: Lens' Activity (Maybe Text)
+acContent = makeAesonLensMb "content" acRest
+
+acGenerator :: Lens' Activity (Maybe Object)
+acGenerator = makeAesonLens "generator" acRest
+
+acIcon :: Lens' Activity (Maybe MediaLink)
+acIcon = makeAesonLensMb "icon" acRest
+
+acId :: Lens' Activity (Maybe Text)
+acId = makeAesonLensMb "id" acRest
+
+acPublished :: Lens' Activity DateTime
+acPublished = makeAesonLens "published" acRest
+
+acProvider :: Lens' Activity (Maybe Object)
+acProvider = makeAesonLensMb "provider" acRest
+
+acTarget :: Lens' Activity (Maybe Object)
+acTarget = makeAesonLensMb "target" acRest
+
+acTitle :: Lens' Activity (Maybe Text)
+acTitle = makeAesonLensMb "title" acRest
+
+acUpdated :: Lens' Activity (Maybe DateTime)
+acUpdated = makeAesonLensMb "updated" acRest
+
+acURL :: Lens' Activity (Maybe Text)
+acURL = makeAesonLensMb "url" acRest
+
+acVerb :: (FromJSON v, ToJSON v) => Lens' Activity (Maybe v)
+acVerb = makeAesonLensMb "verb" acRest
+
+-- | Create an @Activity@ with an @actor@, @published@, and
+--   @provider@ property.
+makeActivity :: Object -> DateTime -> Object -> Activity
+makeActivity actor published provider = Activity
+  $ HM.insert "actor"     (toJSON actor)
+  $ HM.insert "published" (toJSON published)
+  $ HM.insert "provider"  (toJSON provider)
+  $ HM.empty
+
+-- | Collection
+
+data Collection = Collection { fromCollection :: A.Object } deriving (Eq, Show)
+
+instance FromJSON Collection where
+  parseJSON (A.Object o) = return (Collection o)
+  parseJSON _            = fail "..."
+
+instance ToJSON Collection where
+  toJSON (Collection o) = A.Object o
+
+cRest :: Lens' Collection A.Object
+cRest = makeLens fromCollection (\ o' m -> m { fromCollection = o' })
+
+cTotalItems :: Lens' Collection (Maybe Int)
+cTotalItems = makeAesonLensMb "totalItems" cRest
+
+cItems :: Lens' Collection (Maybe [Object])
+cItems = makeAesonLensMb "items" cRest
+
+cURL :: Lens' Collection (Maybe Text)
+cURL = makeAesonLensMb "url" cRest
+
+-- | Create a @Collection@ with an @items@ and a @url@ property
+--   and fill in the corresponding @totalItems@ field with the
+--   length of the @items@ array.
+makeCollection :: [Object] -> Text -> Collection
+makeCollection objs url = Collection
+  $ HM.insert "totalItems" (toJSON (length objs))
+  $ HM.insert "items"      (toJSON objs)
+  $ HM.insert "url"        (toJSON url)
+  $ HM.empty

activitystreams-aeson.cabal

@@ -16,9 +16,10 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 library
-  exposed-modules:     Codec.ActivityStream.Representation,
+  exposed-modules:     Codec.ActivityStream.Dynamic,
+                       Codec.ActivityStream.Representation,
                        Codec.ActivityStream.Schema,
                        Codec.ActivityStream
   other-modules:       Codec.ActivityStream.Internal
   build-depends:       base >=4.7 && <4.8, aeson, text, url, lens, datetime, unordered-containers
-  default-language:    Haskell2010
+  default-language:    Haskell2010