beeminder-api-1.0: Network/Beeminder/Internal.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Network.Beeminder.Internal where
import Blaze.ByteString.Builder
import Control.Applicative
import Control.Lens hiding ((&), (.=))
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson hiding (encode)
import Data.Aeson.Encode.Shim (encode)
import Data.Aeson.Types
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Char
import Data.Conduit
import Data.Default.Class
import Data.Default.Instances.Base
import Data.List
import Data.Maybe
import Data.Monoid hiding (All, Last)
import Data.Ratio
import Data.Scientific (Scientific)
import Data.Set (Set)
import Data.String
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock.POSIX
import Data.Universe
import Data.Universe.Helpers
import Network.HTTP.Conduit
import Network.HTTP.Types
import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder
import qualified Data.ByteString as BS
import qualified Data.Set as Set
import qualified Data.Vector as Vector
-- things that ought to be in somebody else's module/package {{{
renderSimpleQueryText b xs = toByteString (renderQueryText b [(x, Just y) | (x, y) <- xs])
urlEncodedBodyText xs = urlEncodedBody [(encodeUtf8 x, encodeUtf8 y) | (x, y) <- xs]
instance Default Text where def = ""
-- }}}
type Token = ByteString
baseReq token segments = def
{ secure = True
, host = "www.beeminder.com"
, port = 443
, path = toByteString (encodePathSegments ("api":"v1":segments) <> Builder.fromString ".json")
, queryString = "?auth_token=" <> token
}
infixl 4 &
req & q
| BS.null (queryString req) = req { queryString = renderSimpleQueryText True q }
| otherwise = req { queryString = queryString req <> "&" <> renderSimpleQueryText False q }
-- TODO: make some top-level documentation with these details:
-- * all times are an Integer representing a Unix timestamp
-- * something about requested IDs, like how to request them and how to use them -- can they be used anywhere a normal ID can? (answer: no, they cannot)
class HasID a where _ID :: Simple Lens a Text
class HasUpdatedAt a where _UpdatedAt :: Simple Lens a Integer -- ^ you can use this to decide whether or not to use cached information
class HasName a where _Name :: Simple Lens a Text
class HasTimezone a where _Timezone :: Simple Lens a Text
class HasUsername a where _Username :: Simple Lens a (Maybe Text)
class HasGoals a where _Goals :: Simple Lens a UserGoals
class HasGoalsFilter a where _GoalsFilter :: Simple Lens a (Maybe Burner)
class HasLevelOfDetail a where _LevelOfDetail :: Simple Lens a LevelOfGoalDetail
class HasPointCount a where _PointCount :: Simple Lens a (Maybe Integer)
class HasTimestamp a where _Timestamp :: Simple Lens a Integer
class HasValue a where _Value :: Simple Lens a Double
class HasComment a where _Comment :: Simple Lens a Text
class HasRequestID a where _RequestID :: Simple Lens a (Maybe Text)
class HasGoal a where _Goal :: Simple Lens a Text
class HasPointRequest a where _PointRequest :: Simple Lens a PointRequest
class HasPointRequests a where _PointRequests :: Simple Lens a [PointRequest]
class HasGetPoints a where _GetPoints :: Simple Lens a Bool
class HasTitle a where _Title :: Simple Lens a Text
class HasType a where _Type :: Simple Lens a GoalType
class HasTarget a where _Target :: Simple Lens a Target
class HasBehavior a where _Behavior :: Simple Lens a (Set Behavior)
class HasPanic a where _Panic :: Simple Lens a Double
data UserGoals
= Slugs [Text] -- ^ just the short names (use 'JustTheSlugs')
| Hashes [Goal] -- ^ information about all currently existing goals (use 'EverythingCurrent')
| Diff [Goal] [Text] -- ^ created or updated goals first, then IDs of deleted goals (use 'Diff')
deriving (Eq, Ord, Show, Read)
-- | the '_UpdatedAt' value is the upper bound of all updates -- even nested
-- ones to goals, points, etc.
data User = User
{ uName :: Text
, uTimezone :: Text
, uGoals :: UserGoals
, uID :: Text
, uUpdatedAt :: Integer
} deriving (Eq, Ord, Show, Read)
instance HasName User where _Name = lens uName (\s b -> s { uName = b })
instance HasTimezone User where _Timezone = lens uTimezone (\s b -> s { uTimezone = b })
instance HasGoals User where _Goals = lens uGoals (\s b -> s { uGoals = b })
instance HasID User where _ID = lens uID (\s b -> s { uID = b })
instance HasUpdatedAt User where _UpdatedAt = lens uUpdatedAt (\s b -> s { uUpdatedAt = b })
-- internal type used to get a free list instance when parsing the Diff part of UserGoals
data ID = ID { idID :: Text } deriving (Eq, Ord, Show, Read)
instance HasID ID where _ID = lens idID (\s b -> s { idID = b })
instance FromJSON ID where
parseJSON (Object v) = ID <$> v .: "id"
parseJSON o = typeMismatch "ID" o
instance FromJSON UserGoals where
-- diff comes before hashes so that it is preferred when deleted_goals exists
-- TODO: this isn't quite right... Diff is clearly differentiable from
-- Slugs and Hashes, but those two (Slugs and Hashes) aren't differentiable
-- when the goals list is empty -- need something better than a heuristic here!
-- possible resolution: have separate User types for each?
parseJSON (Object v) = slugs <|> diff <|> hashes where
slugs = Slugs <$> v .: "goals"
hashes = Hashes <$> v .: "goals"
diff = Diff <$> v .: "goals" <*> (map idID <$> v .: "deleted_goals")
parseJSON o = typeMismatch "hash with goals (either a list of slugs or a list of goal objects)" o
-- TODO: the implementation doesn't match the spec: it has "id" and
-- "has_authorized_fitbit" fields. I wonder what they're for!
instance FromJSON User where
parseJSON o@(Object v) = User
<$> v .: "username"
<*> v .: "timezone"
<*> parseJSON o
<*> v .: "id"
<*> v .: "updated_at"
parseJSON o = typeMismatch "user object" o
data Burner = Front | Back deriving (Eq, Ord, Show, Read, Bounded, Enum)
instance FromJSON Burner where parseJSON = showStringChoices "burner" (++"burner")
-- TODO: list the attributes that you still get with 'skinny' (and test a call with skinny=True)
data LevelOfGoalDetail
= JustTheSlugs -- ^ minimal detail: just the "slug" (the part that goes in a URL)
| EverythingCurrent -- ^ details about all the currently existing goals
-- the above blank line and the below breech of style are intentional haddock workarounds
-- | maximal detail: report even about goals that have been deleted
| DiffSince
{ since :: Integer -- ^ a Unix timestamp; show all the changes since that timestamp (new points, deleted goals, etc.)
, skinny :: Bool -- ^ when 'True', return only each goal's latest data point and a subset of the attributes for each goal
}
deriving (Eq, Ord, Show, Read)
instance Default LevelOfGoalDetail where def = JustTheSlugs
data UserParameters = UserParameters
{ upUsername :: Maybe Text -- ^ 'Nothing' means \"whoever owns the API token\"
, upGoalsFilter :: Maybe Burner -- ^ 'Nothing' means \"all goals\"; the 'Front' and 'Back' 'Burner's are the goals above and below the fold in the web interface
, upLevelOfDetail :: LevelOfGoalDetail -- ^ how much information do you want about the user's goals?
, upPointCount :: Maybe Integer -- ^ 'Nothing' means return all data points; 'Just' @n@ will return only the @n@ most recently added (not most recently timestamped!) data points
} deriving (Eq, Ord, Show, Read)
instance Default UserParameters where def = UserParameters def def def def
-- TODO: look into using Control.Lens.TH.makeFields to reduce this boilerplate
instance HasUsername UserParameters where _Username = lens upUsername (\s b -> s { upUsername = b })
instance HasGoalsFilter UserParameters where _GoalsFilter = lens upGoalsFilter (\s b -> s { upGoalsFilter = b })
instance HasLevelOfDetail UserParameters where _LevelOfDetail = lens upLevelOfDetail (\s b -> s { upLevelOfDetail = b })
instance HasPointCount UserParameters where _PointCount = lens upPointCount (\s b -> s { upPointCount = b })
maybeMe :: HasUsername a => a -> Text
maybeMe v = fromMaybe "me" (view _Username v)
textShow, lowerShow :: Show a => a -> Text
textShow = fromString . show
lowerShow = fromString . map toLower . show
user :: Token -> UserParameters -> Request
user t p
= baseReq t ["users", maybeMe p]
& case view _LevelOfDetail p of
JustTheSlugs -> []
EverythingCurrent -> [("associations", "true")]
DiffSince t d -> [("diff_since", lowerShow t), ("skinny", lowerShow d)]
++ [("goals_filter", lowerShow b) | Just b <- [view _GoalsFilter p]]
++ [("datapoints_count", lowerShow n) | Just n <- [view _PointCount p]]
data TimeFrame = Year | Month | Week | Day | Hour deriving (Eq, Ord, Show, Read, Bounded, Enum)
data Direction = Up | Down deriving (Eq, Ord, Show, Read, Bounded, Enum)
data Aggregate = Last | First | All | Min | Max | Mean | Sum
deriving (Eq, Ord, Show, Read, Bounded, Enum)
instance FromJSON TimeFrame where parseJSON = showStringChoices "timeframe" (take 1)
instance FromJSON Aggregate where parseJSON = showStringChoices "aggregate" id
instance FromJSON Direction where
parseJSON (Number (toRational -> 1)) = return Up
parseJSON (Number (toRational -> -1)) = return Down
parseJSON v = typeMismatch "direction (either 1 or -1)" v
showStringChoices s f = stringChoices s [(f . map toLower . show $ a, a) | a <- universeF]
stringChoices s cs_ v =
case v of
String t -> case lookup t cs of
Just r -> return r
Nothing -> wrong
_ -> wrong
where
cs = [(fromString n, r) | (n, r) <- cs_]
ns = map fst cs
ns' = init ns
n = last ns
wrong = typeMismatch errorMessage v
errorMessage = s <> " (" <> errorInternal <> ")"
errorInternal = case ns of
[] -> "there are no values of this type!"
[n] -> "must be " <> show n
[n, n'] -> "either " <> show n <> " or " <> show n'
_ -> "one of " <> intercalate "," (map show ns') <> ", or " <> show n
data Behavior
= Exponential -- ^ interpret rate as multiplicative rather than additive
| Cumulative -- ^ plot values as the sum of the points
| Odometer -- ^ treat zero as an odomoter reset rather than a literal 0
| Edgy -- ^ initial data point goes at the road edge (not center)
| Noisy -- ^ use points (not just rate) when computing road width
| StepLine -- ^ use steppy-like line when rendering the graph
| Rosy -- ^ show the optimistic rosy dots when rendering the graph
| MovingAverage -- ^ graph the moving average
| Aura -- ^ render the turquoise confidence area
| Ephemeral -- ^ garbage collect this goal after a bit
| Secret -- ^ only the owner can see the goal
| SecretPoints -- ^ only the owner can see the points
deriving (Eq, Ord, Show, Read, Bounded, Enum)
parseBehaviorSet v = do
behaviors <- mapM (parseBehavior v) universeF
return (Set.fromList [b | (b, h) <- behaviors, polarity b h])
where
parseBehavior v b = (,) b <$> (v .: fieldName b)
fieldName Exponential = "exprd"
fieldName Cumulative = "kyoom"
fieldName Odometer = "odom"
fieldName Edgy = "edgy"
fieldName Noisy = "noisy"
fieldName StepLine = "steppy"
fieldName Rosy = "rosy"
fieldName MovingAverage = "movingav"
fieldName Aura = "aura"
fieldName Ephemeral = "ephem"
fieldName Secret = "secret"
fieldName SecretPoints = "datapublic"
polarity SecretPoints = not
polarity _ = id
data Target
= MissingDate { tValue :: Double, tRate :: Double }
| MissingValue { tDate :: Integer, tRate :: Double }
| MissingRate { tDate :: Integer, tValue :: Double }
deriving (Eq, Ord, Show, Read)
toDouble :: Scientific -> Double
toDouble = fromRational . toRational
toIntegerMaybe :: Scientific -> Maybe Integer
toIntegerMaybe s
| denominator r == 1 = Just $ numerator r
| otherwise = Nothing
where
r = toRational s
toTarget o (Null ) (Number v) (Number r) = return $ MissingDate (toDouble v) (toDouble r)
toTarget o (Number (toIntegerMaybe -> Just t)) (Null ) (Number r) = return $ MissingValue t (toDouble r)
toTarget o (Number (toIntegerMaybe -> Just t)) (Number v) (Null ) = return $ MissingRate t (toDouble v)
toTarget o _ _ _ = typeMismatch "target: two out of three values of [goal date,value,rate]" o
instance FromJSON Target where
parseJSON o@(Array vs) = case Vector.toList vs of
[t, v, r] -> toTarget o t v r
_ -> typeMismatch "target: two out of three values of [goal date,value,rate]" o
parseJSON o = typeMismatch "target (array)" o
data Contract
= Free
| Pledge { cPledge :: Integer }
| Stepdown { cPledge :: Integer, cAt :: Integer }
deriving (Eq, Ord, Show, Read)
instance FromJSON Contract where
parseJSON o@(Object v) = stepdown <|> pledge where
stepdown = Stepdown <$> v .: "amount" <*> v .: "stepdown_at"
pledge = Pledge <$> v .: "amount"
parseJSON Null = pure Free
parseJSON o = typeMismatch "contract (object)" o
-- TODO: Goals don't match the spec: they have an "id", "graphsum", and "rah"
-- fields. I wonder what they're for!
data Goal = Goal
{ gID :: Text
, gGoal :: Text
, gUpdatedAt :: Integer
, gBurner :: Burner
, gTitle :: Text
, gTarget :: Target
, gRatePeriod :: TimeFrame
, gGraph :: Text -- ^ URL of graph image TODO: can this be computed from gID?
, gThumb :: Text -- ^ URL of graph thumb TODO: can this be computed from gID?
, gLoseDate :: Integer -- ^ assuming no more data reported
, gPanic :: Double -- ^ how many seconds before 'gLoseDate' to FREAK OUT
, gQueued :: Bool -- ^ is graph still rendering?
, gPoints :: [Point] -- ^ empty unless you explicitly ask for it not to be
, gPointCount :: Integer
, gPledge :: Integer
, gStartDate :: Integer
, gStartValue :: Double
, gCurrentDate :: Integer
, gCurrentValue :: Double
, gReportedDate :: Integer
, gYaw :: Direction -- ^ which side of the road is good?
, gSlope :: Direction -- ^ which way is the road going? TODO: can this be inferred from gRate? (what happens when a downward-sloping graph gets dialed to an upward slope?)
, gLane :: Integer
, gMathIsHard :: (Integer, Double, Double) -- ^ date, value, and rate??? TODO: can this be inferred from gTarget (or vice versa)? if not, what's the difference??
, gSummary :: (Text, Text, Text) -- headsum, limsum, graphsum
, gWon :: Bool -- TODO: can this be inferred from current date, gDate, and gLoseDate?
, gFrozen :: Bool -- TODO: is this gWon || gLost?
, gLost :: Bool -- TODO: can this be inferred from current date, gDate, and gLoseDate? (what happens in the grace period?)
, gContract :: Contract -- ^ the current pledge (TODO: can this be inferred from gPledge or vice versa?) and the date of a scheduled future stepdown, if any
, gRoad :: [Target]
, gAggregate :: Aggregate -- ^ what to do with multiple points on a given day
, gBehavior :: Set Behavior
} deriving (Eq, Ord, Show, Read)
-- TODO: lens instances for Goal
instance FromJSON Goal where
parseJSON o@(Object v) = Goal
<$> v .: "id"
<*> v .: "slug"
<*> v .: "updated_at"
<*> v .: "burner"
<*> v .: "title"
<*> join (liftA3 (toTarget o) (v .: "goaldate") (v .: "goalval") (v .: "rate"))
<*> v .: "runits"
<*> v .: "graph_url"
<*> v .: "thumb_url"
<*> v .: "losedate"
<*> v .: "panic"
<*> v .: "queued"
<*> (v .: "datapoints" <|> pure [])
<*> v .: "numpts"
<*> v .: "pledge"
<*> v .: "initday"
<*> v .: "initval"
<*> v .: "curday"
<*> v .: "curval"
<*> v .: "lastday"
<*> v .: "yaw"
<*> v .: "dir"
<*> v .: "lane"
<*> v .: "mathishard"
<*> liftA3 (,,) (v .: "headsum") (v .: "limsum") (v .: "graphsum")
<*> v .: "won"
<*> v .: "frozen"
<*> v .: "lost"
<*> v .: "contract"
<*> v .: "road"
<*> v .: "aggday"
<*> parseBehaviorSet v
parseJSON o = typeMismatch "goal (object)" o
data GoalType = Hustler | Biker | FatLoser | Gainer | Inboxer | Drinker deriving (Eq, Ord, Show, Read, Bounded, Enum)
instance Default GoalType where def = minBound
-- hustler biker fatloser gainer inboxer drinker
-- yaw 1 1 -1 1 -1 -1
-- dir 1 1 -1 1 -1 1
-- exprd false false false false false false
-- kyoom true false false false false true
-- odom false true false false false false
-- edgy false false false false false true
-- noisy false false true true false false
-- aggday all all min last min all
-- steppy true true false false true true
-- rosy false false true true false false
-- movingav false false true true false false
-- aura false false true true false false
gType :: Goal -> Maybe GoalType
gType g = case (gYaw g, gSlope g, gAggregate g, mungeBehavior g) of
(Up , Up , All , [Cumulative, StepLine] ) -> Just Hustler
(Up , Up , All , [Odometer, StepLine] ) -> Just Biker
(Down, Down, Min , [Noisy, Rosy, MovingAverage, Aura]) -> Just FatLoser
(Up , Up , Last, [Noisy, Rosy, MovingAverage, Aura]) -> Just Gainer
(Down, Down, Min , [StepLine] ) -> Just Inboxer
(Down, Up , All , [Cumulative, Edgy, StepLine] ) -> Just Drinker
_ -> Nothing
where
mungeBehavior = filter (`notElem` [Secret, SecretPoints]) . Set.toAscList . gBehavior
-- | You will not like the '_Goal' you get from the 'Default' instance. The
-- 'Goal' you get will have @_Points = []@ unless you explicitly ask for the
-- points by setting '_GetPoints'.
data GoalParameters = GoalParameters
{ gpUsername :: Maybe Text
, gpGoal :: Text
, gpGetPoints :: Bool
} deriving (Eq, Ord, Show, Read)
instance Default GoalParameters where def = GoalParameters def def False
instance HasUsername GoalParameters where _Username = lens gpUsername (\s b -> s { gpUsername = b })
instance HasGoal GoalParameters where _Goal = lens gpGoal (\s b -> s { gpGoal = b })
instance HasGetPoints GoalParameters where _GetPoints = lens gpGetPoints (\s b -> s { gpGetPoints = b })
goal :: Token -> GoalParameters -> Request
goal t p = baseReq t ["users", maybeMe p, "goals", view _Goal p]
& [("datapoints", "true") | view _GetPoints p]
data AllGoalsParameters = AllGoalsParameters
{ agpUsername :: Maybe Text
, agpGoalsFilter :: Maybe Burner
} deriving (Eq, Ord, Show, Read)
instance Default AllGoalsParameters where def = AllGoalsParameters def def
instance HasUsername AllGoalsParameters where _Username = lens agpUsername (\s b -> s { agpUsername = b })
instance HasGoalsFilter AllGoalsParameters where _GoalsFilter = lens agpGoalsFilter (\s b -> s { agpGoalsFilter = b })
allGoals :: Token -> AllGoalsParameters -> Request
allGoals t p = baseReq t ["users", maybeMe p, "goals"]
& [("filter", lowerShow b <> "burner") | Just b <- [view _GoalsFilter p]]
-- | You will not like the '_Goal' you get from the 'Default' instance, and
-- you almost certainly will also not like the '_Title', '_Type', or '_Target'
-- you get. The only behaviors that will be respected in the '_Behavior' are
-- 'Ephemeral', 'Secret', and 'SecretPoints'; all the remaining behaviors will
-- be set according to the '_Type'.
data CreateGoalParameters = CreateGoalParameters
{ cgpUsername :: Maybe Text
, cgpGoal :: Text
, cgpTitle :: Text
, cgpType :: GoalType
, cgpTarget :: Target
, cgpValue :: Double
, cgpBehavior :: Set Behavior
, cgpPanic :: Double
} deriving (Eq, Ord, Show, Read)
-- given in the spec; this is 15 hours
defaultPanic = 54000
instance Default CreateGoalParameters where def = CreateGoalParameters def def def def (MissingDate 1 1) def (Set.singleton SecretPoints) defaultPanic
instance HasUsername CreateGoalParameters where _Username = lens cgpUsername (\s b -> s { cgpUsername = b })
instance HasGoal CreateGoalParameters where _Goal = lens cgpGoal (\s b -> s { cgpGoal = b })
instance HasTitle CreateGoalParameters where _Title = lens cgpTitle (\s b -> s { cgpTitle = b })
instance HasType CreateGoalParameters where _Type = lens cgpType (\s b -> s { cgpType = b })
instance HasTarget CreateGoalParameters where _Target = lens cgpTarget (\s b -> s { cgpTarget = b })
instance HasValue CreateGoalParameters where _Value = lens cgpValue (\s b -> s { cgpValue = b })
instance HasBehavior CreateGoalParameters where _Behavior = lens cgpBehavior (\s b -> s { cgpBehavior = b })
instance HasPanic CreateGoalParameters where _Panic = lens cgpPanic (\s b -> s { cgpPanic = b })
createGoal :: Token -> CreateGoalParameters -> Request
createGoal t p = urlEncodedBodyText (
[ ("slug" , view _Goal $ p)
, ("title" , view _Title $ p)
, ("goal_type" , lowerShow . view _Type $ p)
, ("initval" , lowerShow . view _Value $ p)
, ("ephem" , lowerShow . Set.member Ephemeral . view _Behavior $ p)
, ("panic" , lowerShow . view _Panic $ p)
, ("secret" , lowerShow . Set.member Secret . view _Behavior $ p)
, ("datapublic", lowerShow . Set.notMember SecretPoints . view _Behavior $ p)
, ("dryrun" , "false") -- TODO: delete
]
++ renderTarget (view _Target p)
)
(baseReq t ["users", maybeMe p, "goals"])
where
renderTarget (MissingDate v r) = [ ("goalval", lowerShow v), ("rate", lowerShow r)]
renderTarget (MissingValue t r) = [("goaldate", lowerShow t), ("rate", lowerShow r)]
renderTarget (MissingRate t v ) = [("goaldate", lowerShow t), ("goalval", lowerShow v) ]
data Point = Point
{ pTimestamp :: Integer
, pValue :: Double
, pComment :: Text
, pRequestID :: Maybe Text
, pID :: Text
, pUpdatedAt :: Integer
} deriving (Eq, Ord, Show, Read)
instance HasTimestamp Point where _Timestamp = lens pTimestamp (\s b -> s { pTimestamp = b })
instance HasValue Point where _Value = lens pValue (\s b -> s { pValue = b })
instance HasComment Point where _Comment = lens pComment (\s b -> s { pComment = b })
instance HasRequestID Point where _RequestID = lens pRequestID (\s b -> s { pRequestID = b })
instance HasID Point where _ID = lens pID (\s b -> s { pID = b })
instance HasUpdatedAt Point where _UpdatedAt = lens pUpdatedAt (\s b -> s { pUpdatedAt = b })
instance FromJSON Point where
parseJSON o@(Object v) = Point
<$> v .: "timestamp"
<*> v .: "value"
<*> v .: "comment"
<*> v .: "requestid"
<*> v .: "id"
<*> v .: "updated_at"
parseJSON o = typeMismatch "point" o
-- | You will not like the '_Goal' you get from the 'Default' instance.
data PointsParameters = PointsParameters
{ ppUsername :: Maybe Text
, ppGoal :: Text
} deriving (Eq, Ord, Show, Read)
instance Default PointsParameters where def = PointsParameters def def
instance HasUsername PointsParameters where _Username = lens ppUsername (\s b -> s { ppUsername = b })
instance HasGoal PointsParameters where _Goal = lens ppGoal (\s b -> s { ppGoal = b })
points :: Token -> PointsParameters -> Request
points t p = baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints"]
-- | You will not like the '_Timestamp' or '_Value' you get from the
-- 'Default' instance. You may like 'now'.
data PointRequest = PointRequest
{ prTimestamp :: Integer
, prValue :: Double
, prComment :: Text
, prRequestID :: Maybe Text
} deriving (Eq, Ord, Show, Read)
instance Default PointRequest where def = PointRequest def def def def
instance HasTimestamp PointRequest where _Timestamp = lens prTimestamp (\s b -> s { prTimestamp = b })
instance HasValue PointRequest where _Value = lens prValue (\s b -> s { prValue = b })
instance HasComment PointRequest where _Comment = lens prComment (\s b -> s { prComment = b })
instance HasRequestID PointRequest where _RequestID = lens prRequestID (\s b -> s { prRequestID = b })
instance ToJSON PointRequest where
toJSON p = object $
[ "timestamp" .= view _Timestamp p
, "value" .= view _Value p
, "comment" .= view _Comment p
] ++
[ "requestid" .= requestid | Just requestid <- [view _RequestID p]]
-- | Set the timestamp to the current time.
now :: (MonadIO m, HasTimestamp a) => a -> m a
now a = liftIO $ flip (set _Timestamp) a . round <$> getPOSIXTime
-- TODO: perhaps we shouldn't have separate createPoint and createPoints! After
-- all, the latter completely subsumes the former, and we can internally check
-- the length of the list to decide what to do if the single-point creation API
-- call turns out to be better for some reason.
-- | You will not like the '_Goal', '_Timestamp', or '_Value' you get from the
-- 'Default' instance. You may like 'now'.
data CreatePointParameters = CreatePointParameters
{ cppUsername :: Maybe Text
, cppGoal :: Text
, cppPointRequest :: PointRequest
} deriving (Eq, Ord, Show, Read)
instance Default CreatePointParameters where def = CreatePointParameters def def def
instance HasUsername CreatePointParameters where _Username = lens cppUsername (\s b -> s { cppUsername = b })
instance HasGoal CreatePointParameters where _Goal = lens cppGoal (\s b -> s { cppGoal = b })
instance HasPointRequest CreatePointParameters where _PointRequest = lens cppPointRequest (\s b -> s { cppPointRequest = b })
instance HasTimestamp CreatePointParameters where _Timestamp = _PointRequest . _Timestamp
instance HasValue CreatePointParameters where _Value = _PointRequest . _Value
instance HasComment CreatePointParameters where _Comment = _PointRequest . _Comment
instance HasRequestID CreatePointParameters where _RequestID = _PointRequest . _RequestID
-- | You will not like the '_Goal' or '_PointRequests' you get from the
-- 'Default' instance.
data CreatePointsParameters = CreatePointsParameters
{ cpspUsername :: Maybe Text
, cpspGoal :: Text
, cpspPointRequests :: [PointRequest]
} deriving (Eq, Ord, Show, Read)
instance Default CreatePointsParameters where def = CreatePointsParameters def def def
instance HasUsername CreatePointsParameters where _Username = lens cpspUsername (\s b -> s { cpspUsername = b })
instance HasGoal CreatePointsParameters where _Goal = lens cpspGoal (\s b -> s { cpspGoal = b })
instance HasPointRequests CreatePointsParameters where _PointRequests = lens cpspPointRequests (\s b -> s { cpspPointRequests = b })
createPoint , createPointNotify :: Token -> CreatePointParameters -> Request
createPoints, createPointsNotify :: Token -> CreatePointsParameters -> Request
createPointNotify = createPointInternal True
createPoint = createPointInternal False
tsvcArgs p =
[ ("timestamp", (textShow . view _Timestamp) p)
, ("value" , (textShow . view _Value ) p)
, ("comment" , ( view _Comment ) p)
]
createPointInternal sendmail t p = urlEncodedBodyText
( tsvcArgs p
++ [("requestid", r) | Just r <- [view _RequestID p]]
++ [("sendmail" , "true") | sendmail]
)
-- TODO: unify with the other occurrence of users/me/goals/goal-name/datapoints
(baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints"])
createPointsNotify = createPointsInternal True
createPoints = createPointsInternal False
createPointsInternal sendmail t p = urlEncodedBody
([("datapoints", toStrict . encode . view _PointRequests $ p)] ++
[("sendmail" , "true") | sendmail]
)
(baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints", "create_all"])
-- | You will not like the '_Goal', '_ID', '_Timestamp', or '_Value' you get
-- from the 'Default' instance. You may like 'now'.
data UpdatePointParameters = UpdatePointParameters
{ uppUsername :: Maybe Text
, uppGoal :: Text
, uppID :: Text
, uppTimestamp :: Integer
, uppValue :: Double
, uppComment :: Text
} deriving (Eq, Ord, Show, Read)
instance Default UpdatePointParameters where def = UpdatePointParameters def def def def def def
instance HasUsername UpdatePointParameters where _Username = lens uppUsername (\s b -> s { uppUsername = b })
instance HasGoal UpdatePointParameters where _Goal = lens uppGoal (\s b -> s { uppGoal = b })
instance HasID UpdatePointParameters where _ID = lens uppID (\s b -> s { uppID = b })
instance HasTimestamp UpdatePointParameters where _Timestamp = lens uppTimestamp (\s b -> s { uppTimestamp = b })
instance HasValue UpdatePointParameters where _Value = lens uppValue (\s b -> s { uppValue = b })
instance HasComment UpdatePointParameters where _Comment = lens uppComment (\s b -> s { uppComment = b })
updatePoint :: Token -> UpdatePointParameters -> Request
updatePoint t p = (urlEncodedBodyText
(tsvcArgs p)
(baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints", view _ID p])
) { method = "PUT" }
-- TODO: is there some commonality that we can pull out from this and other parameters data types??
-- | You will not like the '_Goal' or '_ID' you get from the 'Default'
-- instance.
data DeletePointParameters = DeletePointParameters
{ dppUsername :: Maybe Text
, dppGoal :: Text
, dppID :: Text
} deriving (Eq, Ord, Show, Read)
instance Default DeletePointParameters where def = DeletePointParameters def def def
instance HasUsername DeletePointParameters where _Username = lens dppUsername (\s b -> s { dppUsername = b })
instance HasGoal DeletePointParameters where _Goal = lens dppGoal (\s b -> s { dppGoal = b })
instance HasID DeletePointParameters where _ID = lens dppID (\s b -> s { dppID = b })
deletePoint :: Token -> DeletePointParameters -> Request
deletePoint t p = (baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints", view _ID p]) { method = "DELETE" }
-- Finite instances {{{
instance Universe Burner where universe = universeDef
instance Universe TimeFrame where universe = universeDef
instance Universe Aggregate where universe = universeDef
instance Universe Direction where universe = universeDef
instance Universe Behavior where universe = universeDef
instance Universe GoalType where universe = universeDef
instance Finite Burner
instance Finite TimeFrame
instance Finite Aggregate
instance Finite Direction
instance Finite Behavior
instance Finite GoalType
-- }}}