{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}

-- | A client for scrobbling, based upon the Audioscrobbler Realtime
-- Submission protocol v1.2
-- <http://www.audioscrobbler.net/development/protocol/>
--
-- Example:
--
-- @
-- import Scrobble.Client
-- import Data.Time
--
-- example = do
--   client <- newClient Details
--     { detPassword = \"YOURPASS\"
--     , detUsername = \"YOURUSER\"
--     , detClient   = \"qlb\"
--     , detVersion  = \"0.9.2\"
--     , detServer   = defaultServer
--     }
--   nowPlaying client NowPlaying
--     { npArtist      = \"Kasabian\"
--     , npTrack       = \"Ladies and Gentlemen\"
--     , npAlbum       = Just \"West Ryder Pauper Lunatic Asylum\"
--     , npLength      = Just 288
--     , npPosition    = Nothing
--     , npMusicBrainz = Nothing
--     }
--   timestamp <- getCurrentTime
--   submitTracks client
--                [Submission { subArtist      = \"Kasabian\"
--                            , subTrack       = \"Ladies and Gentlemen\"
--                            , subTimestamp   = timestamp
--                            , subSource      = UserChosen
--                            , subRating      = Nothing
--                            , subLength      = Just 288
--                            , subAlbum       = Just \"West Ryder Pauper Lunatic Asylum\"
--                            , subPosition    = Nothing
--                            , subMusicBrainz = Nothing
--                            }]
-- @

module Scrobble.Client
  (newClient
  ,nowPlaying
  ,submitTracks
  ,defaultServer
  ,module Scrobble.Types)
  where

import Scrobble.Types

import Control.Arrow
import Control.Exception
import Control.Monad
import Data.Hash.MD5 (Str(..),md5s)
import Data.List
import Data.Maybe
import Data.Time
import Data.Time.Clock.POSIX
import Network.Curl
import Network.URI
import System.Locale

-- | Get a session token.
--
-- The algorithm for generating this token is as follows:
-- token := md5(md5(password) + timestamp)
--
-- The md5() function takes a string and returns the 32-byte ASCII
-- hexadecimal representation of the MD5 hash, using lower case
-- characters for the hex values.
getToken :: String    -- ^ The password.
         -> IO (String,String) -- ^ A session token and timestamp.
getToken password = do
  timestamp <- getCurrentTime
  let et = epoch timestamp
  return (md5 (md5 password ++ et),et)

    where md5 = md5s . Str

-- | Create a client session. Throws "ScrobblerError".
newClient :: Details -> IO Client
newClient Details{..} = withCurlDo $ do
  (token,timestamp) <- getToken detPassword
  let params = [("hs","true")
               ,("p","1.2")
               ,("c",detClient)
               ,("v",detVersion)
               ,("u",detUsername)
               ,("t",timestamp)
               ,("a",token)]
  response <- curlGrab (setQuery detServer params)
           [CurlHttpHeaders [ "Host: " ++ host
                            | Just host <- [fmap uriRegName (uriAuthority detServer)] ]]
  parseAuth response

-- | Parse the auth response.
parseAuth :: CurlGrab -> IO Client
parseAuth CurlGrab{..} =
  case lines grabBody of
    ["OK",token,parseURI -> Just nowplaying,parseURI -> Just submit] ->
      return (Client token nowplaying submit)
    ["BANNED"] -> throw ScrobblerBanned
    ["BADAUTH"] -> throw ScrobblerBadAuth
    ["BADTIME"] -> throw ScrobblerBadTime
    [other] | isPrefixOf failed other ->
              throw (ScrobblerFailed (drop (length failed) other))
            | otherwise -> throw ScrobblerHardFail
  where failed = "FAILED "

-- | Default Audioscrobbler server: http://post.audioscrobbler.com/
defaultServer :: URI
defaultServer = fromJust (parseURI "http://post.audioscrobbler.com/")

-- | Send a now playing message.  Throws "ScrobblerError".
nowPlaying :: Client -> NowPlaying -> IO ()
nowPlaying client@Client{..} nowplaying = do
  CurlGrab{grabBody} <- curlGrab cliNowPlaying
                                 [CurlPost True
                                 ,CurlPostFields (map keyval (makeNowPlaying client nowplaying))]
  unless (trim grabBody == "OK") $
    throw (ScrobblerNowPlayingFail grabBody)

-- | Make a now playing query.
makeNowPlaying :: Client -> NowPlaying -> [(String,String)]
makeNowPlaying Client{..} NowPlaying{..} =
  [("s",cliToken)
  ,("a",npArtist)
  ,("t",npTrack)
  ,("b",fromMaybe "" npAlbum)
  ,("l",maybe "" show npLength)
  ,("n",maybe "" show npPosition)
  ,("m",fromMaybe "" npMusicBrainz)]

-- | Submit track(s).  Throws "ScrobblerError".
submitTracks :: Client -> [Submission] -> IO ()
submitTracks client@Client{..} submissions = do
  CurlGrab{grabBody} <- curlGrab cliSubmit
                                 [CurlPost True
                                 ,CurlPostFields (map keyval params)]
  unless (trim grabBody == "OK") $
    throw (ScrobblerSubmitFail grabBody)

  where params = [("s",cliToken)] ++
                 concat (zipWith (makeSubmission client) [0..] submissions)

-- | Make a now playing query.
makeSubmission :: Client -> Integer -> Submission -> [(String,String)]
makeSubmission Client{..} i Submission{..} = map hookup
  [("a",subArtist)
  ,("t",subTrack)
  ,("i",epoch subTimestamp)
  ,("o",fromMaybe "U" (lookup subSource sources))
  ,("r",fromMaybe "" (subRating >>= \r -> lookup r ratings))
  ,("l",maybe "" show subLength)
  ,("b",fromMaybe "" subAlbum)
  ,("n",maybe "" show subPosition)
  ,("m",fromMaybe "" subMusicBrainz)]

  where sources = [(UserChosen,"P")
                  ,(NonPersonlizedBroadcast,"R")
                  ,(Personalized,"E")
                  ,(LastFm,"L")]
        ratings = [(Love,"L"),(Ban,"B"),(Skip,"S")]
        hookup (k,v) = (k ++ "[" ++ show i ++ "]",v)

--------------------------------------------------------------------------------
-- Utilities

-- | Encode post parameters to a string.
encodePost :: [(String,String)] -> String
encodePost = intercalate "&" . map (keyval . (encode *** encode)) where
  encode = escapeURIString isUnescapedInURI

-- | Make a key=val string.
keyval :: (String,String) -> String
keyval (key,val) = key ++ "=" ++ val

-- | Set a URI's query.
setQuery :: URI -> [(String,String)] -> URI
setQuery uri assoc = uri { uriQuery = "?" ++ encodePost assoc }

-- | Format a time to UNIX number.
epoch :: UTCTime -> String
epoch = formatTime defaultTimeLocale "%s"

-- | Just strip whitespace.
trim :: String -> String
trim = unwords . words

--------------------------------------------------------------------------------
-- Make Curl's API not crappy.

-- | Grab a URL with curl.
curlGrab :: URI -> [CurlOption] -> IO CurlGrab
curlGrab url options = do
  CurlResponse{..} <- curlGetResponse_ (show url) options
  return $ CurlGrab respCurlCode respStatus respStatusLine respHeaders respBody

-- | A sane data type.
data CurlGrab = CurlGrab
  { grabCode       :: CurlCode
  , grabStatus     :: Int
  , grabStatusLine :: String
  , grabHeaders    :: [(String,String)]
  , grabBody       :: String
  } deriving (Show)