-- | MimiIMDB - a web server that implements a mini version of www.imdb.com
-- taking information from a PostgreSQL database that has been populated
-- with the data sets available for download from
-- <https://datasets.imdbws.com/>
module Main(main) where -- haddock requires this
import Network.Shed.Httpd
import Database.HDBC
import Database.HDBC.PostgreSQL
import Network.URI(uriPath,uriQuery)
import Codec.Binary.UTF8.String(encodeString)
import Data.Maybe(listToMaybe)
import SimpleHTML
import SqlRows

-- | Connect to the database and start the HTTP server
main = do db <- connectPostgreSQL "dbname=imdb"
          initServer 8020 (miniImdb db)

-- | HTTP Request handler
miniImdb db request@Request{reqMethod="GET",reqURI=url} = miniImdbGet db url
miniImdb db req = return badRequestResponse

-- | HTTP GET request handler
miniImdbGet db url =
  case (uriPath url,inputs (uriQuery url)) of
    ("/",[]) -> return (htmlResponse startPage)
    ("/title",[("tt",tt)]) -> miniImdbShowTitle db tt
    ("/name", [("nm",nm)]) -> miniImdbShowName db nm
    ("/title",[("q",q)]) -> miniImdbSearchTitle db q
    ("/name", [("q",q)]) -> miniImdbSearchName db q
    ("/miniimdb.css", _) -> return (okResponse "text/css" miniImdbCss)
    _ -> return notFoundResponse
  where
    inputs = queryToArguments . fixplus
      where
        fixplus = concatMap decode
        decode '+' = "%20" -- httpd-shed bug workaround
        decode c   = [c]

--------------------------------------------------------------------------------
-- ** Search result pages

-- | Title search result page
miniImdbSearchTitle db q = titleListPage <$> findTitles db q
  where
    titleListPage titles = 
       htmlResponse $
       imdbPage ("Title search result for "++q) $
             ol (map (li.titleLink) titles)

-- | Name search result page
miniImdbSearchName db q = nameListPage <$> findNames db q
  where
    nameListPage names = 
      htmlResponse $
      imdbPage ("Name search result for "++q) $
            ol (map (li.nameLink) names)

-- | Name info page
miniImdbShowName db nm = personPage <$> nameInfo db nm <*> nameTitles db nm
  where
    personPage info@(name,y1,y2,pp) titles =
      htmlResponse $
      imdbPage (name++optYears y1 y2) $
      p (maybe mempty text pp) <>
      p (link ("https://www.imdb.com/name/"++nm) (text "IDMB"))<>
      h3 "Filmography" <>
      ol (map (li.titleInfo) titles)

    titleInfo (tt,title,y1,y2,cat,cs,r) =
      titleLink (tt,title,y1,y2)<>optParen r<>
      text " "<>maybe mempty text cat<>
      text " "<>maybe mempty text cs

-- | Title info page
miniImdbShowTitle db tt =
    titlePage <$> titleInfo db tt <*> titleRating db tt <*> titleNames db tt
  where
    titlePage info@(title,y1,y2,genres) mrating names =
      htmlResponse $
      imdbPage (title++optYears y1 y2) $
      p (maybe mempty rating mrating)<>
      p (maybe mempty text genres)<>
      p (link ("https://www.imdb.com/title/"++tt)(text "IDMB"))<>
      h3 "Principal cast & crew " <>
      ol (map (li.nameInfo) names)

    rating (ar,nv) =
      text ("Average rating: "++show ar++" ("++show nv++" votes)")

    nameInfo (nm,name,y1,y2,cat,cs) =
      nameLink (nm,name,y1,y2)<>
      text " "<>maybe mempty text cat<>
      text " "<>maybe mempty text cs


--------------------------------------------------------------------------------
-- ** HTML output helper functions

titleLink :: (TConst,Title,Year,Year) -> HTML
titleLink (tt,title,y1,y2) =
    link ("/title?tt="++tt) (text title)<>text (optYears y1 y2)

nameLink :: (NConst,Name,Year,Year) -> HTML
nameLink  (nm,name,y1,y2)  =
    link ("/name?nm="++nm) (text name)<>text (optYears y1 y2)

optParen x = maybe mempty (parens.text.show) x
parens s = text " ("<>s<>text ")"

optYears :: Year -> Year -> String
optYears y1 y2 =
  case (y1,y2) of
    (Just y1,Just y2) -> " ("++show y1++"-"++show y2++")"
    (Just y1,Nothing) -> " ("++show y1++")"
    (Nothing,Just y2) -> " (?-"++show y2++")"
    (Nothing,Nothing) -> ""

startPage = imdbPage "Start page" body
  where
    body = h3 "Title search" <> search "title"
           <>
           h3 "Name search" <> search "name"

    search name = form name (input "q" name <> submit "Search")

imdbPage subtitle body =
  show $
  page (title++" - "++subtitle) "/miniimdb.css"
       (header (h1 title) <>
        main_ (h2 subtitle<>body)<>
        footer (link "/" (text "MiniIMDB")))
  where
    title = "MiniIMDB"

---------------------------------------------------------------------------------- ** Style sheet

miniImdbCss = unlines [
  "body { background: #bdf; }",
  "main { background: #f0f0f0; padding: 5px; border: 1.5px solid black; }",
  "h1 { margin-bottom: 0; }",
  "h2 { margin-top: 0; }",
  "h1,h2,h3 { color: #006; font-family: sans-serif; }",
  "",
  "footer { text-align: right; }"]

---------------------------------------------------------------------------------- ** HTTP responses

badRequestResponse = Response 400 [] "Bad request"
notFoundResponse   = Response 404 [] "Not found"

okResponse ty = Response 200 [("Content-Type",ty)] . encodeString

textResponse = okResponse "text/plain"
htmlResponse = okResponse "text/html"

--------------------------------------------------------------------------------
-- ** Database access

type NConst      = String
type TConst      = String
type Name        = String
type Title       = String
type Year        = Maybe Int
type Professions = Maybe String
type Category    = Maybe String
type Characters  = Maybe String
type Genres      = Maybe String
type Rating      = Maybe Double

findNames :: Connection -> Name -> IO [(NConst,Name,Year,Year)]
findNames db q = fromRowsM =<< quickQuery' db query [toSql q]
  where
    query = "SELECT nconst,primaryName,birthYear,deathYear "++
            "FROM Name_basics WHERE primaryName LIKE ?"

findTitles :: Connection -> Title -> IO [(TConst,Title,Year,Year)]
findTitles db q = fromRowsM =<< quickQuery' db query [toSql q]
  where
    query = "SELECT tconst,originalTitle,startYear,endYear "
          ++"FROM Title_basics WHERE originalTitle LIKE ?"
          ++" AND titletype IN ('movie','tvSeries')"
          ++" ORDER BY COALESCE(endYear,startYear,0) DESC"

nameInfo :: Connection -> NConst -> IO (Name,Year,Year,Professions)
nameInfo db nm = oneRowM =<< quickQuery' db query [toSql nm]
  where
    query = "SELECT primaryName,birthYear,deathYear,primaryProfession "
          ++"FROM Name_Basics WHERE nconst = ?"

titleInfo :: Connection -> TConst -> IO (Title,Year,Year,Genres)
titleInfo db tt =
    oneRowM =<< quickQuery' db query [toSql tt]
  where
    query = "SELECT originalTitle,startYear,endYear,genres "++
            "FROM Title_basics WHERE tconst = ?"

titleRating :: Connection -> TConst -> IO (Maybe (Double,Int))
titleRating db tt =
   listToMaybe <$> (fromRowsM =<< quickQuery' db query [toSql tt])
 where
   query = "SELECT averageRating,numVotes FROM Title_Ratings WHERE tconst = ?"

nameTitles :: Connection -> NConst ->
              IO [(TConst,Title,Year,Year,Category,Characters,Rating)]
nameTitles db nm =
    fromRowsM =<< quickQuery' db query [toSql nm]
  where
    query = "SELECT tconst,originalTitle,startYear,endYear,category,characters,averageRating "
          ++"FROM Titles_names_ratings "
          ++"WHERE nconst =? AND titleType in ('movie','tvSeries') "
          ++"ORDER BY COALESCE(endYear,startYear,0) DESC"


titleNames :: Connection -> TConst ->
              IO [(NConst,Name,Year,Year,Category,Characters)]
titleNames db tt =
    fromRowsM =<< quickQuery' db query [toSql tt]
  where
    query = "SELECT nconst,primaryName,birthYear,deathYear,category,characters "
          ++"FROM Titles_names_ratings "
          ++"WHERE tconst = ? AND titleType in ('movie','tvSeries') "