Fixture.hs

{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeOperators    #-}

module Drone.Test.Fixture where

import           Control.Exception.Base
import           Data.Aeson             (FromJSON, eitherDecodeFileStrict)
import           Data.Extensible
import           Drone.Types

type Fixtures = Record
   '[ "user"   >: User
    , "users"  >: [User]
    , "repo"   >: Repo
    , "repos"  >: [Repo]
    , "cron"   >: Cron
    , "crons"  >: [Cron]
    , "build"  >: Build
    , "builds" >: [Build]
    , "logs"   >: [Line]
    ]

newtype JSONParseException =
  JSONParseException String deriving (Show)

instance Exception JSONParseException

readJSON :: FromJSON a => FilePath -> IO a
readJSON path =
  eitherDecodeFileStrict path >>= \case
    Left e  -> throwIO $ JSONParseException ("in " ++ path ++ ": " ++ e)
    Right x -> pure x

readFixtures :: FilePath -> FilePath -> IO Fixtures
readFixtures root suffix = hsequence
    $ #user   <@=> readJSON (root ++ "user.json"   ++ suffix)
   <: #users  <@=> readJSON (root ++ "users.json"  ++ suffix)
   <: #repo   <@=> readJSON (root ++ "repo.json"   ++ suffix)
   <: #repos  <@=> readJSON (root ++ "repos.json"  ++ suffix)
   <: #cron   <@=> readJSON (root ++ "cron.json"   ++ suffix)
   <: #crons  <@=> readJSON (root ++ "crons.json"  ++ suffix)
   <: #build  <@=> readJSON (root ++ "build.json"  ++ suffix)
   <: #builds <@=> readJSON (root ++ "builds.json" ++ suffix)
   <: #logs   <@=> readJSON (root ++ "logs.json"   ++ suffix)
   <: nil