Instances.hs

{- This file is part of funbot.
 -
 - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- For the 'MonadSettings' instance
{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}

-- For JSON field names
{-# LANGUAGE OverloadedStrings #-}

module FunBot.Settings.Instances () where

import Control.Applicative
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.Bool (bool)
import Data.CaseInsensitive (CI)
import Data.Hashable (Hashable)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Settings.Types
import FunBot.Types
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Types.Base (Nickname (..))

import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Lazy as M
import qualified Data.HashSet as S
import qualified Data.Text as T

instance MonadSettings BotSession Settings where
    getSettings      = getStateS bsSettings

    putSettings s    = modifyState $ \ st -> st { bsSettings = s }

    modifySettings f =
        modifyState $ \ st -> st { bsSettings = f $ bsSettings st }

    getSTree         = getStateS bsSTree

instance OptionValue Bool where
    readOption s
        | s' `elem` ["off", "false", "no",  "n", "0", "[_]"] = Just False
        | s' `elem` ["on",  "true",  "yes", "y", "1", "[x]"] = Just True
        | otherwise                                          = Nothing
        where
        s' = T.toLower s
    showOption = bool "False" "True"
    typeName = const "Boolean"

instance OptionValue T.Text where
    readOption = Just
    showOption = id
    typeName = const "String"

instance OptionValue [T.Text] where
    readOption = mapM readOption . T.split (== ',')
    showOption = T.intercalate "," . map showOption
    typeName   = const "List"

instance FromJSON a => FromJSON (Filter a) where
    parseJSON (Object o) =
        Accept <$> o .: "accept" <|>
        Reject <$> o .: "reject"
    parseJSON v          = typeMismatch "Filter" v

instance ToJSON a => ToJSON (Filter a) where
    toJSON (Accept l) = object [ "accept" .= l ]
    toJSON (Reject l) = object [ "reject" .= l ]

instance FromJSON RepoAnnSpec where
    parseJSON (Object o) =
        RepoAnnSpec <$>
        o .: "channel" <*>
        o .: "branches" <*>
        o .: "all-commits" <*>
        o .: "commits" <*>
        o .: "issues" <*>
        o .: "merge-requests" <*>
        o .: "snippets" <*>
        o .: "notes" <*>
        o .: "new" <*>
        o .: "old" <*>
        o .: "untimed"
    parseJSON v          = typeMismatch "RepoAnnSpec" v

instance ToJSON RepoAnnSpec where
    toJSON ras = object
        [ "channel"        .= rasChannel ras
        , "branches"       .= rasBranches ras
        , "all-commits"    .= rasAllCommits ras
        , "commits"        .= rasCommits ras
        , "issues"         .= rasIssues ras
        , "merge-requests" .= rasMergeRequests ras
        , "snippets"       .= rasSnippets ras
        , "notes"          .= rasNotes ras
        , "new"            .= rasNew ras
        , "old"            .= rasOld ras
        , "untimed"        .= rasUntimed ras
        ]

instance FromJSON NewsItemFields where
    parseJSON (Object o) =
        NewsItemFields <$>
        o .: "show-feed-title" <*>
        o .: "show-author" <*>
        o .: "show-url"
    parseJSON v          = typeMismatch "NewsItemFields" v

instance ToJSON NewsItemFields where
    toJSON (NewsItemFields ftitle author url) = object
        [ "show-feed-title" .= ftitle
        , "show-author"     .= author
        , "show-url"        .= url
        ]

instance FromJSON NewsAnnSpec where
    parseJSON (Object o) =
        NewsAnnSpec <$>
        o .: "channels" <*>
        o .: "fields"
    parseJSON v          = typeMismatch "NewsAnnSpec" v

instance ToJSON NewsAnnSpec where
    toJSON (NewsAnnSpec channels fields) = object
        [ "channels" .= channels
        , "fields"   .= fields
        ]

instance FromJSON NewsFeed where
    parseJSON (Object o) =
        NewsFeed <$>
        o .: "url" <*>
        o .: "active" <*>
        o .: "ann-spec"
    parseJSON v          = typeMismatch "NewsFeed" v

instance ToJSON NewsFeed where
    toJSON (NewsFeed url active spec) = object
        [ "url"      .= url
        , "active"   .= active
        , "ann-spec" .= spec
        ]

instance FromJSON a => FromJSON (M.HashMap (CI T.Text) a) where
    parseJSON v =
        let f (t, x) = (CI.mk t, x)
        in  M.fromList . map f . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap (CI T.Text) a) where
    toJSON m =
        let f (t, x) = (CI.original t, x)
        in  toJSON $ M.fromList $ map f $ M.toList m

instance FromJSON a => FromJSON (M.HashMap (RepoSpace, RepoName) a) where
    parseJSON v =
        let mkpair (t, x) =
                case T.split (== '/') t of
                    [space, repo] ->
                        if T.null space || T.null repo
                            then Nothing
                            else Just
                                    ( ( RepoSpace $ CI.mk space
                                      , RepoName $ CI.mk repo
                                      )
                                    , x
                                    )
                    _ -> Nothing
        in  M.fromList . catMaybes . map mkpair . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap (RepoSpace, RepoName) a) where
    toJSON m =
        let unpair ((RepoSpace s, RepoName r), x) = (s <> "/" <> r, x)
        in  toJSON $ M.fromList $ map unpair $ M.toList m

instance FromJSON a => FromJSON (M.HashMap DevHostLabel a) where
    parseJSON v =
        let f (h, x) = (DevHostLabel h, x)
        in  M.fromList . map f . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap DevHostLabel a) where
    toJSON m =
        let f (DevHostLabel h, x) = (h, x)
        in  toJSON $ M.fromList $ map f $ M.toList m

instance FromJSON a => FromJSON (M.HashMap DevHost a) where
    parseJSON v =
        let f (h, x) = (DevHost h, x)
        in  M.fromList . map f . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap DevHost a) where
    toJSON m =
        let f (DevHost h, x) = (h, x)
        in  toJSON $ M.fromList $ map f $ M.toList m

instance FromJSON a => FromJSON (M.HashMap Nickname a) where
    parseJSON v =
        let f (n, x) = (Nickname n, x)
        in  M.fromList . map f . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap Nickname a) where
    toJSON m =
        let f (Nickname n, x) = (n, x)
        in  toJSON $ M.fromList $ map f $ M.toList m

instance FromJSON a => FromJSON (M.HashMap FeedLabel a) where
    parseJSON v =
        let f (l, x) = (FeedLabel l, x)
        in  M.fromList . map f . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap FeedLabel a) where
    toJSON m =
        let f (FeedLabel l, x) = (l, x)
        in  toJSON $ M.fromList $ map f $ M.toList m

instance FromJSON a => FromJSON (M.HashMap ShortcutLabel a) where
    parseJSON v =
        let f (l, x) = (ShortcutLabel l, x)
        in  M.fromList . map f . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap ShortcutLabel a) where
    toJSON m =
        let f (ShortcutLabel l, x) = (l, x)
        in  toJSON $ M.fromList $ map f $ M.toList m

instance FromJSON a => FromJSON (M.HashMap LocationLabel a) where
    parseJSON v =
        let f (l, x) = (LocationLabel l, x)
        in  M.fromList . map f . M.toList <$> parseJSON v

instance ToJSON a => ToJSON (M.HashMap LocationLabel a) where
    toJSON m =
        let f (LocationLabel l, x) = (l, x)
        in  toJSON $ M.fromList $ map f $ M.toList m

instance FromJSON Shortcut where
    parseJSON (Object o) =
        Shortcut <$>
        o .: "prefix" <*>
        o .: "before" <*>
        o .: "after" <*>
        o .: "channels"
    parseJSON v          = typeMismatch "Shortcut" v

instance ToJSON Shortcut where
    toJSON (Shortcut prefix before after chans) = object
        [ "prefix"   .= prefix
        , "before"   .= before
        , "after"    .= after
        , "channels" .= chans
        ]

instance FromJSON ChanSettings where
    parseJSON (Object o) =
        ChanSettings <$>
        o .: "say-titles"                      <*>
        o .: "welcome"                         <*>
        (map Nickname <$> o .: "folks")        <*>
        o .: "email"                           <*>
        (M.map Location <$> o .: "locations")  <*>
        (S.map Nickname <$> o .: "puppeteers") <*>
        o .: "browse"
    parseJSON v          = typeMismatch "ChanSettings" v

instance ToJSON ChanSettings where
    toJSON (ChanSettings sayTitles welcome folks email locs pts url) = object
        [ "say-titles" .= sayTitles
        , "welcome"    .= welcome
        , "folks"      .= map unNickname folks
        , "email"      .= email
        , "locations"  .= M.map unLocation locs
        , "puppeteers" .= S.map unNickname pts
        , "browse"     .= url
        ]

instance FromJSON Settings where
    parseJSON (Object o) =
        Settings <$>
        o .: "repos"                              <*>
        o .: "feeds"                              <*>
        o .: "shortcuts"                          <*>
        o .: "channels"                           <*>
        (M.map DevHostLabel <$> o .: "dev-hosts") <*>
        (M.map Location <$> o .: "locations")     <*>
        (S.map Nickname <$> o .: "puppeteers")
    parseJSON v          = typeMismatch "Settings" v

instance ToJSON Settings where
    toJSON (Settings repos feeds shortcuts channels hosts locs pts) = object
        [ "repos"      .= repos
        , "feeds"      .= feeds
        , "shortcuts"  .= shortcuts
        , "channels"   .= channels
        , "dev-hosts"  .= M.map unDevHostLabel hosts
        , "locations"  .= M.map unLocation locs
        , "puppeteers" .= S.map unNickname pts
        ]