heddit-0.1: io-tests/SubredditSpec.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeApplications #-}

module SubredditSpec ( spec ) where

import           Data.Foldable        ( traverse_ )
import           Data.Generics.Labels ()
import           Data.Time

import           Lens.Micro.GHC

import           Network.Reddit

import           Test.Hspec

spec :: Spec
spec = beforeAll (loadClient Nothing) . describe "Network.Reddit.Subreddit"
    $ sequence_ [ getInfo
                , getTop
                , nameSearch
                , userFlair
                , missingFlair
                , submissionFlair
                , widgets
                , emojis
                , wikipages
                , collections
                , revisions
                ]

getInfo :: SpecWith Client
getInfo = it "gets subreddit info" $ \c -> do
    haskellSub <- mkSubredditName "haskell"
    subreddit <- runReddit c $ getSubreddit haskellSub

    subreddit ^. #name `shouldBe` haskellSub
    subreddit ^. #subredditID `shouldBe` SubredditID "2qh36"
    subreddit ^. #over18 `shouldBe` False
    subreddit ^. #quarantine `shouldBe` False
    subreddit ^. #created `shouldBe` read @UTCTime "2008-01-25 06:37:23 +0000"

getTop :: SpecWith Client
getTop = it "gets the top all-time submission" $ \c -> do
    let opts      = defaultItemOpts & #itemTime ?~ AllTime
        paginator = emptyPaginator & (#limit .~ 1) . (#opts .~ opts)
    haskellSub <- mkSubredditName "haskell"
    listing <- runReddit c $ getTopSubmissions haskellSub paginator
    case listing ^? #children . _head of
        Nothing  -> expectationFailure "Failed to get top submission"
        Just top -> top ^. #submissionID `shouldBe` SubmissionID "6x7ms0"

nameSearch :: SpecWith Client
nameSearch = it "searches subreddits by name" $ \c -> do
    results <- runReddit c $ searchSubredditsByName Nothing Nothing "haskell"
    names <- traverse mkSubredditName [ "haskell", "haskellquestions" ]
    traverse_ (shouldContain (results ^.. each) . pure) names

userFlair :: SpecWith Client
userFlair = it "gets user flair templates" $ \c -> do
    flairTemplates
        <- runReddit c $ getUserFlairTemplates =<< mkSubredditName "linux"
    case flairTemplates ^? _head of
        Nothing    -> expectationFailure "Failed to get flair templates"
        Just flair -> do
            flairText <- mkFlairText ":linux:"
            flair ^. #text `shouldBe` flairText
            flair ^. #textEditable `shouldBe` False
            flair ^. #textColor `shouldBe` Just Dark
            flair ^. #allowableContent `shouldBe` AllContent

missingFlair :: SpecWith Client
missingFlair =
    it "throws the correct exception if user flair is not allowed" $ \c -> do
        let action = getUserFlairTemplates =<< mkSubredditName "haskell"
            ex     = \case
                ErrorWithStatus (StatusMessage 403 "Forbidden") -> True
                _ -> False
        runReddit c action `shouldThrow` ex

submissionFlair :: SpecWith Client
submissionFlair = it "gets new submission flair choices" $ \c -> do
    haskellSub <- mkSubredditName "haskell"
    choices <- runReddit c (getNewSubmissionFlairChoices haskellSub)
    case choices ^? _head of
        Nothing    -> expectationFailure "Failed to get flair choices"
        Just flair -> do
            flairText <- mkFlairText "announcement"
            flair ^. #text `shouldBe` flairText
            flair ^. #textEditable `shouldBe` False
            flair ^. #cssClass `shouldBe` Nothing

widgets :: SpecWith Client
widgets = it "gets subreddit widgets" $ \c -> do
    ws <- runReddit c $ getSubredditWidgets =<< mkSubredditName "haskell"

    let idCard = ws ^. #idCard
        idcID  = WidgetID "id-card-2qh36"
    idcName <- mkShortName "Community Details"
    idCard ^. #widgetID `shouldBe` Just idcID
    idCard ^. #shortName `shouldBe` idcName

    let mods     = ws ^. #moderators
        modsID   = WidgetID "moderators-2qh36"
        modNames = mods ^.. #mods . each . #name
    dons <- mkUsername "dons"
    mods ^. #widgetID `shouldBe` Just modsID
    modNames `shouldContain` [ dons ]

emojis :: SpecWith Client
emojis = it "gets subreddit emojis" $ \c -> do
    es <- runReddit c $ getSubredditEmojis =<< mkSubredditName "linux"
    emojiName <- mkEmojiName "nix"
    case es ^? each . filtered ((== emojiName) . (^. #name)) of
        Nothing    -> expectationFailure "Failed to get subreddit emojis"
        Just emoji -> do
            emoji ^. #modFlairOnly `shouldBe` False
            emoji ^. #postFlairAllowed `shouldBe` True
            emoji ^. #userFlairAllowed `shouldBe` True
            emoji ^. #createdBy `shouldBe` Just (UserID "den0g")

wikipages :: SpecWith Client
wikipages = it "gets subreddit wiki pages" $ \c -> do
    pages <- runReddit c $ getWikiPages =<< mkSubredditName "linux"
    pages ^.. each `shouldContain` [ mkWikiPageName "index" ]

revisions :: SpecWith Client
revisions = it "gets wiki page revisions" $ \c -> do
    let pageName  = mkWikiPageName "index"
        paginator = emptyPaginator & #limit .~ 1
    linuxSub <- mkSubredditName "linux"
    revs <- runReddit c $ getWikiPageRevisions linuxSub pageName paginator
    case revs ^? #children . _head of
        Nothing  -> expectationFailure "Failed to get wiki page revisions"
        Just rev -> do
            page <- runReddit c . getWikiPageRevision linuxSub pageName
                $ rev ^. #revisionID

            rev ^. #author `shouldBe` page ^. #revisionBy

collections :: SpecWith Client
collections = it "gets subreddit collections" $ \c -> do
    pages <- runReddit c $ getWikiPages =<< mkSubredditName "linux"
    pages ^.. each `shouldContain` [ mkWikiPageName "index" ]