Handle.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Katip.Tests.Scribes.Handle
  ( tests,
  )
where

-------------------------------------------------------------------------------
import Control.Monad
import Data.Aeson
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as BL
import Data.Monoid as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LT
import Data.Time
-------------------------------------------------------------------------------
import Katip
import Language.Haskell.TH.Syntax (Loc (..))
import Lens.Micro ((.~))
import System.Directory
import System.IO
import Test.Tasty
import Test.Tasty.Golden
import Test.Tasty.HUnit
import Text.Regex.TDFA

-------------------------------------------------------------------------------

tests :: TestTree
tests =
  testGroup
    "Katip.Scribes.Handle"
    [ withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do
        (path, h, fin, le) <- setupScribe
        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"
        fin
        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"
        hClose h
        res <- readFile path
        let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
        let matches = res =~ pat
        assertBool (show res M.<> " did not match") matches,
      withResource setupFile (const (return ())) $ \setupScribe -> testCase "logs correct data to a file" $ do
        (path, fin, le) <- setupScribe
        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"
        fin
        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"
        res <- readFile path
        let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
        let matches = res =~ pat
        assertBool (show res <> " did not match") matches,
      withResource setupTempFile teardownTempFile $ \setupFn ->
        goldenVsString
          "Text-golden"
          goldenTextPath
          (setupFn >>= writeTextLog),
      withResource setupTempFile teardownTempFile $ \setupFn ->
        goldenVsString
          "Json-golden"
          goldenJsonPath
          (setupFn >>= writeJsonLog)
    ]

#if MIN_VERSION_aeson(2, 0, 0)
-- keys get reordered, hence different output
goldenTextPath :: FilePath
goldenTextPath = "test/Katip/Tests/Scribes/Handle-text-aeson2.golden"
goldenJsonPath :: FilePath
goldenJsonPath = "test/Katip/Tests/Scribes/Handle-json-aeson2.golden"
#elif MIN_VERSION_unordered_containers(0, 2, 16)
goldenTextPath :: FilePath
goldenTextPath = "test/Katip/Tests/Scribes/Handle-text-aeson2.golden"
goldenJsonPath :: FilePath
goldenJsonPath = "test/Katip/Tests/Scribes/Handle-json-aeson2.golden"
#else
goldenTextPath :: FilePath
goldenTextPath = "test/Katip/Tests/Scribes/Handle-text.golden"
goldenJsonPath :: FilePath
goldenJsonPath = "test/Katip/Tests/Scribes/Handle-json.golden"
#endif

-------------------------------------------------------------------------------
data DummyLogItem = DummyLogItem
  { dliNote :: Text
  }

instance ToJSON DummyLogItem where
  toJSON dli =
    object
      [ "note"
          .= object
            [ "deep" .= dliNote dli
            ]
      ]

instance ToObject DummyLogItem

instance LogItem DummyLogItem where
  payloadKeys _ _ = AllKeys

-------------------------------------------------------------------------------
dummyLogItem :: DummyLogItem
dummyLogItem = DummyLogItem "some note"

-------------------------------------------------------------------------------
setup :: IO (FilePath, Handle, IO (), LogEnv)
setup = do
  tempDir <- getTemporaryDirectory
  (fp, h) <- openTempFile tempDir "katip.log"
  s <- mkHandleScribe (ColorLog False) h (permitItem DebugS) V3
  le <- initLogEnv "katip-test" "test"
  le' <- registerScribe "handle" s defaultScribeSettings le
  return (fp, h, void (closeScribes le'), le')

-------------------------------------------------------------------------------
teardown :: (a, Handle, b, c) -> IO ()
teardown (_, h, _, _) = do
  chk <- hIsOpen h
  when chk $ hClose h

-------------------------------------------------------------------------------
setupFile :: IO (FilePath, IO (), LogEnv)
setupFile = do
  tempDir <- getTemporaryDirectory
  (fp, h) <- openTempFile tempDir "katip.log"
  hClose h
  s <- mkFileScribe fp (permitItem DebugS) V3
  le <- initLogEnv "katip-test" "test"
  le' <- registerScribe "handle" s defaultScribeSettings le
  return (fp, void (closeScribes le'), le')

-- Following code tests Handle scribe output against a golden file.
-- This test will fail on non utf8 locales because golden file is in utf-8.
-- It generates all meaningfull variations of Item, and also tests
-- writing of payload of different Aeson constructors
--
-- Note: currently Handle scribe does not write Array items at all
-------------------------------------------------------------------------------
data AllTypesLogItem = AllTypesLogItem
  { atlText :: Text,
    atlNum :: Int,
    atlFloat :: Float,
    atlList :: [Text],
    atlSub :: Maybe DummyLogItem
  }

instance ToJSON AllTypesLogItem where
  toJSON it =
    object
      [ "text" .= atlText it,
        "num" .= atlNum it,
        "float" .= atlFloat it,
        "list" .= atlList it,
        "sub" .= atlSub it
      ]

instance ToObject AllTypesLogItem

instance LogItem AllTypesLogItem where
  payloadKeys _ _ = AllKeys

-------------------------------------------------------------------------------
theItem :: Item DummyLogItem
theItem =
  Item
    (Namespace ["app"])
    (Environment "production")
    (InfoS)
    (ThreadIdText "1337")
    "example"
    7331
    dummyLogItem
    "message"
    (mkUTCTime 2016 6 12 12 34 56)
    (Namespace ["foo"])
    Nothing

genItems :: [Item DummyLogItem]
genItems =
  concat $
    [ [ itemSeverity .~ s $ theItem
        | s <- [minBound .. maxBound]
      ],
      [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem
        | t <- [0 :: Int, 1, 1337, 2147483647]
      ],
      [ itemHost .~ h $ theItem
        | h <- ["example", "www.example.com", "127.0.0.1"]
      ],
      [ itemProcess .~ p $ theItem
        | p <- [0, 1, 1337, 2147483647]
      ],
      [ itemMessage .~ LogStr m $ theItem
        | m <-
            [ "message",
              "message\nwith newline",
              LT.fromLazyText (LT.replicate 40 " a really long message"),
              "сообщение",
              "哈囉世界"
            ]
      ],
      [ itemTime .~ t $ theItem
        | t <- genDates
      ],
      [ itemNamespace .~ Namespace ns $ theItem
        | ns <-
            [ ["foo"],
              ["foo", "bar"],
              ["фу", "бар"],
              ["with\nnewline"]
            ]
      ],
      [ itemLoc .~ l $ theItem | l <- genLocs
      ]
    ]

genDates :: [UTCTime]
genDates =
  [ mkUTCTime 2000 1 1 0 0 0.0,
    mkUTCTime 2123 12 31 23 59 59.999999999999,
    mkUTCTime 2016 10 10 1 1 5.0,
    mkUTCTime 2100 12 31 12 59 10.1,
    mkUTCTime 1982 1 1 12 30 0.000000000001
  ]

genLocs :: [Maybe Loc]
genLocs =
  [ Nothing,
    Just $
      Loc
        "path/Some/Module.hs"
        "main"
        "Some.Module"
        (30, 1)
        (30, 14),
    Just $
      Loc
        "путь/Some/Module.hs"
        "main"
        "Some.Module"
        (3000, 9000)
        (4000, 1)
  ]

genTypedItems :: [Item AllTypesLogItem]
genTypedItems =
  [ itemPayload .~ p $ theItem
    | p <-
        [ AllTypesLogItem "" 0 0.0 [] Nothing,
          AllTypesLogItem
            "note"
            10
            5.5
            ["one", "two", "three"]
            (Just dummyLogItem)
        ]
  ]

mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
mkUTCTime y mt d h mn s = UTCTime day dt
  where
    day = fromGregorian y mt d
    dt = h * 60 * 60 + mn * 60 + s

-------------------------------------------------------------------------------
writeTextLog :: (FilePath, Handle) -> IO (BL.ByteString)
writeTextLog = writeFormattedLog bracketFormat

writeJsonLog :: (FilePath, Handle) -> IO (BL.ByteString)
writeJsonLog = writeFormattedLog jsonFormat

writeFormattedLog :: (forall a. LogItem a => ItemFormatter a) -> (FilePath, Handle) -> IO (BL.ByteString)
writeFormattedLog format (path, h) = do
  mapM_ (put . formatOne) genItems
  mapM_ (put . formatOne) genTypedItems
  hClose h
  BL.readFile path
  where
    formatOne :: LogItem a => Item a -> Text
    formatOne = LT.toStrict . LT.toLazyText . format False V3
    put = B.hPutStrLn h . T.encodeUtf8

setupTempFile :: IO (FilePath, Handle)
setupTempFile = do
  tempDir <- getTemporaryDirectory
  (fp, h) <- openBinaryTempFile tempDir "katip.log"
  return (fp, h)

teardownTempFile :: (FilePath, Handle) -> IO ()
teardownTempFile (_, h) = do
  chk <- hIsOpen h
  when chk $ hClose h