Calendar.hs 2.34 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}

module Calendar
  ( Credentials
  , Scope
  , Context
  , initialize
  , listCalendars
  ) where

import           ClassyPrelude.Yesod
import           Control.Lens                           ((.~), (<&>), (^.))
import           Control.Monad.Logger                   (Loc, LogSource, LogStr, defaultLoc)
import           Data.ByteString.Builder                (toLazyByteString)
import           Network.Google.AppsCalendar
import           System.Log.FastLogger                  (toLogStr)
import qualified Data.Aeson as Js
import qualified Network.Google       as Google
import qualified Network.Google.Auth  as Google
import qualified Network.Google.Auth.ApplicationDefault as Google

type Scope = '[ "https://www.googleapis.com/auth/calendar"]

mockClientId :: Text
mockClientId = "mock"

data Credentials
  = MockCreds
  | GoogleCreds (Google.Credentials Scope)

instance Show Credentials where
  show MockCreds = "<mock>"
  show (GoogleCreds _) = "<google>"

instance FromJSON Credentials where
  parseJSON = Js.withObject "Credentials" $ \o ->
    o .: "client_id" >>= \c ->
    if c == mockClientId
    then return MockCreds
    else either fail (return . GoogleCreds) $
         Google.fromJSONCredentials $ Js.encode o

data Context
  = MockCxt
  | GoogleCxt (Google.Env Scope)

type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

initialize :: LogFunc -> Manager -> Credentials -> IO Context
54
55
56
initialize appLog _ MockCreds = do
  appLog defaultLoc "" LevelWarn "Using mock calendar"
  return MockCxt
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
initialize appLog manager (GoogleCreds creds) =
  GoogleCxt <$>
  (Google.newEnvWith creds gooLog manager <&> Google.envScopes .~ calendarScope)
  where
    gooLog level builder =
      appLog defaultLoc "" lv (toLogStr (toLazyByteString builder))
      where
        lv = case level of
               Google.Info  -> LevelInfo
               Google.Error -> LevelError
               Google.Debug -> LevelDebug
               Google.Trace -> LevelOther "trace"

listCalendars :: MonadResource m => Context -> m [Text]
listCalendars MockCxt = return []
listCalendars (GoogleCxt env) = do
  xs <- Google.runGoogle env $ Google.send calendarListList
  return $ mapMaybe (^. cleSummary) (xs ^. clItems)