Internal.hs

-- |
-- Module       : Flowdock.Internal
-- License      : MIT License
-- Maintainer   : Gabriel McArthur <gabriel.mcarthur@gmail.com>
-- Stability    : experimental
-- Portability  : portable

module Flowdock.Internal
  ( createUrl
  , underscoreCase
  , picosecondsToUTCTime
  ) where

import           Blaze.ByteString.Builder
import           Blaze.ByteString.Builder.Char.Utf8
import           Data.ByteString            (ByteString)
import           Data.Char                  (isUpper, toLower)
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import           Data.Text.Encoding         (encodeUtf8)
import           Data.Time.Clock            (UTCTime, NominalDiffTime)
import           Data.Time.Clock.POSIX      (posixSecondsToUTCTime)
import           Data.Maybe
import           Data.Monoid
import           Network.HTTP.Types.URI

-- | Create a URL from a base URL and a list of relative paths, returning
-- the full URL
createUrl :: [Text]         -- ^ Relative paths
          -> [(Text, Text)] -- ^ Query parameters
          -> ByteString
createUrl relativePaths params = toByteString $
    if null params
      then path
      else path <> queryString
  where
    stripSlashes txt = txt''
      where
        txt' = if "/" `Text.isSuffixOf` txt
                  then fromJust $ Text.stripSuffix "/" txt
                  else txt
        txt'' = if "/" `Text.isPrefixOf` txt'
                  then fromJust $ Text.stripPrefix "/" txt'
                  else txt'

    path = foldr ((\p acc -> fromText "/" <> p <> acc) . fromText . stripSlashes) mempty relativePaths

    paramToQuery (k,v) = let k' = encodeUtf8 k in
                         if Text.null v
                           then (k', Nothing)
                           else (k', Just $ encodeUtf8 v)

    queryString = renderQueryBuilder True $ map paramToQuery params

underscoreCase :: String -> String
underscoreCase = underscoreCase' True
  where
    underscoreCase' _    []       = []
    underscoreCase' prev (x : xs) = if isUpper x
                                      then if prev
                                             then toLower x : underscoreCase' True xs
                                             else '_' : toLower x : underscoreCase' True xs
                                      else x : underscoreCase' False xs

-- | Turns picoseconds into UTCTime
picosecondsToUTCTime :: Integer -> UTCTime
picosecondsToUTCTime pico = posixSecondsToUTCTime posixSeconds
    where
      posixSeconds :: NominalDiffTime
      posixSeconds = fromInteger $ pico `div` (1000000 :: Integer)