{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Debian.Sources
    {- ( SourceType(..)
    , SourceOption(..)
    , SourceOp(..)
    , DebSource(..)
    , parseSourceLine
    , parseSourceLine'
    , parseSourcesList
    ) -} where

import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import Data.Text (Text)
import Debian.Pretty (PP(..))
import Debian.Release
import Network.URI (URI, uriToString, parseURI, unEscapeString, escapeURIString, isAllowedInURI)
import Test.HUnit
import Text.ParserCombinators.Parsec
import Text.PrettyPrint (hcat, punctuate, render, text)
import Text.PrettyPrint.HughesPJClass (Pretty(pPrint))

data SourceType
    = Deb | DebSrc
    deriving (Eq, Ord, Show)

-- arch
-- lang
-- target
-- pdiffs
-- by-hash
-- allow-insecure=no
-- allow-weak=no
-- allow-downgrade-to-insecure=no
-- trusted=no
-- signed-by
-- check-valid-until
-- valid-until-min
-- valid-until-max
data SourceOption
    = SourceOption String SourceOp [String]
    deriving (Eq, Ord, Show)

data SourceOp = OpSet | OpAdd | OpDel deriving (Eq, Ord, Show)

instance Pretty SourceOp where
    pPrint OpSet = text "="
    pPrint OpAdd = text "+="
    pPrint OpDel = text "-="

data DebSource
    = DebSource
    { sourceType :: SourceType
    , sourceOptions :: [SourceOption]
    , sourceUri :: URI
    , sourceDist :: Either String (ReleaseName, [Section])
    } deriving (Eq, Ord, Show)

instance Pretty SourceType where
    pPrint Deb = text "deb"
    pPrint DebSrc = text "deb-src"

instance Pretty SourceOption where
    pPrint (SourceOption k op vs) = text k <> pPrint op <> hcat (punctuate (text ",") (map text vs))

instance Pretty DebSource where
    pPrint (DebSource thetype theoptions theuri thedist) =
        hcat (punctuate (text " ")
                ([pPrint thetype] ++
                 (case theoptions of
                    [] -> []
                    _ -> [text "[" <> hcat (punctuate (text ", ") (map pPrint theoptions)) <> text "]"]) ++
                 [text (uriToString id theuri "")] ++
                 case thedist of
                   Left exactPath -> [text (escapeURIString isAllowedInURI exactPath)]
                   Right (dist, sections) ->
                       map text (releaseName' dist : map sectionName' sections)))

instance Pretty (PP [DebSource]) where
    pPrint = hcat . map (\ x -> pPrint x <> text "\n") . unPP

-- |This is a name given to a combination of parts of one or more
-- releases that can be specified by a sources.list file.
type SliceName = ReleaseName
-- data SliceName = SliceName { sliceName :: String } deriving (Eq, Ord, Show)

{-

deb uri distribution [component1] [componenent2] [...]

The URI for the deb type must specify the base of the Debian
distribution, from which APT will find the information it needs.

distribution can specify an exact path, in which case the components
must be omitted and distribution must end with a slash (/).

If distribution does not specify an exact path, at least one component
must be present.

Distribution may also contain a variable, $(ARCH), which expands to
the Debian architecture (i386, m68k, powerpc, ...)  used on the
system.

The rest of the line can be marked as a comment by using a #.

Additional Notes:

 + Lines can begin with leading white space.

 + If the dist ends with slash (/), then it must be an absolute path
   and it is an error to specify components after it.

-}

-- |quoteWords - similar to words, but with special handling of
-- double-quotes and brackets.
--
-- The handling double quotes and [] is supposed to match:
-- apt-0.6.44.2\/apt-pkg\/contrib\/strutl.cc:ParseQuoteWord()
--
-- The behaviour can be defined as:
--
--  Break the string into space seperated words ignoring spaces that
--  appear between \"\" or []. Strip trailing and leading white space
--  around words. Strip out double quotes, but leave the square
--  brackets intact.
quoteWords :: String -> [String]
quoteWords [] = []
quoteWords s = quoteWords' (dropWhile (==' ') s)
    where
      quoteWords' :: String -> [String]
      quoteWords' [] = []
      quoteWords' str =
          case break (flip elem (" [\"" :: String)) str of
            ([],[]) -> []
            (w, []) -> [w]
            (w, (' ':rest)) -> w : (quoteWords' (dropWhile (==' ') rest))
            (w, ('"':rest)) ->
                case break (== '"') rest of
                  (w',('"':rest)) ->
                      case quoteWords' rest of
                        [] ->  [w ++ w']
                        (w'':ws) -> ((w ++ w' ++ w''): ws)
                  (_w',[]) -> error ("quoteWords: missing \" in the string: "  ++ s)
                  _ -> error ("the impossible happened in SourcesList.quoteWords")
            (w, ('[':rest)) ->
                case break (== ']') rest of
                  (w',(']':rest)) ->
                      case quoteWords' rest of
                        []       -> [w ++ "[" ++ w' ++ "]"]
                        (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws)
                  (_w',[]) -> error ("quoteWords: missing ] in the string: "  ++ s)
                  _ -> error ("the impossible happened in SourcesList.quoteWords")
            _ -> error ("the impossible happened in SourcesList.quoteWords")

stripLine :: String -> String
stripLine = takeWhile (/= '#') . dropWhile (== ' ')

sourceLines :: String -> [String]
sourceLines = filter (not . null) . map stripLine . lines

-- |parseSourceLine -- parses a source line
-- the argument must be a non-empty, valid source line with comments stripped
-- see: 'sourceLines'
parseSourceLine :: String -> DebSource
parseSourceLine str = either error id (parseSourceLine' str)
{-
    case quoteWords str of
      (theTypeStr : theUriStr : theDistStr : sectionStrs) ->
          let sections = map parseSection' sectionStrs
              theType = case unEscapeString theTypeStr of
                          "deb" -> Deb
                          "deb-src" -> DebSrc
                          o -> error ("parseSourceLine: invalid type " ++ o ++ " in line:\n" ++ str)
              theUri = case parseURI theUriStr of
                         Nothing -> error ("parseSourceLine: invalid uri " ++ theUriStr ++ " in the line:\n" ++ str)
                         Just u -> u
              theDist = unEscapeString theDistStr
          in
            case last theDist of
              '/' -> if null sections
                      then DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Left theDist }
                      else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str)
              _ -> if null sections
                    then error ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str)
                    else DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Right (parseReleaseName theDist, sections) }
      _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str)
-}

parseOptions :: String -> Either ParseError [SourceOption]
parseOptions s = parse pOptions s s

pOptions :: CharParser () [SourceOption]
pOptions = do _ <- char '['
              skipMany (oneOf [' ','\t'])
              opts <- sepBy1 pOption (char ',')
              skipMany (oneOf [' ','\t'])
              _ <- char ']'
              return opts

pOption :: CharParser () SourceOption
pOption = do skipMany (oneOf [' ','\t'])
             key <- many1 (noneOf ['+','-','=',' ','\t'])
             skipMany (oneOf [' ','\t'])
             op <- pOp
             skipMany (oneOf [' ','\t'])
             values <- sepBy1 (many1 (noneOf [',',']',' ','\t'])) (char ',')
             skipMany (oneOf [' ','\t'])
             return $ SourceOption key op values

pOp :: CharParser () SourceOp
pOp = do (char '+' >> char '=' >> return OpAdd)
         <|>
         (char '-' >> char '=' >> return OpDel)
         <|>
         (char '=' >> return OpSet)

parseSourceLine' :: String -> Either String DebSource
parseSourceLine' str =
    case quoteWords str of
      theTypeStr : theOptionStr@('[' : _) : theURIStr : theDistStr : sectionStrs ->
          either
            (Left . show)
            (\opts -> go theTypeStr opts theURIStr theDistStr sectionStrs)
            (parseOptions theOptionStr)
      theTypeStr : theURIStr : theDistStr : sectionStrs ->
          go theTypeStr [] theURIStr theDistStr sectionStrs
      _ -> Left ("parseSourceLine: invalid line in sources.list:\n" ++ str)
    where
      go theTypeStr theOptions theURIStr theDistStr sectionStrs =
          let sections = map parseSection' sectionStrs
              theType = case unEscapeString theTypeStr of
                          "deb" -> Right Deb
                          "deb-src" -> Right DebSrc
                          s -> Left ("parseSourceLine: invalid type " ++ s ++ " in line:\n" ++ str)
              theURI = case parseURI theURIStr of
                         Nothing -> Left ("parseSourceLine: invalid uri " ++ theURIStr ++ " in the line:\n" ++ str)
                         Just u -> Right u
              theDist = unEscapeString theDistStr
          in
            case (last theDist, theType, theURI) of
              ('/', Right typ, Right uri) -> if null sections
                      then Right $ DebSource { sourceType = typ, sourceOptions = theOptions, sourceUri = uri, sourceDist = Left theDist }
                      else Left ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str)
              (_, Right typ, Right uri) -> if null sections
                    then Left ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str)
                    else Right $ DebSource { sourceType = typ, sourceOptions = theOptions, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) }
              (_, Left msg, _) -> Left msg
              (_, _, Left msg) -> Left msg

parseSourcesList :: String -> [DebSource]
parseSourcesList = map parseSourceLine . sourceLines

-- * Unit Tests

-- TODO: add test cases that test for unterminated double-quote or bracket
testQuoteWords :: Test
testQuoteWords =
    test [ assertEqual "Space seperate words, no quoting" ["hello", "world","!"] (quoteWords "  hello    world !  ")
         , assertEqual "Space seperate words, double quotes" ["hello  world","!"] (quoteWords "  hel\"lo  world\" !  ")
         , assertEqual "Space seperate words, square brackets" ["hel[lo  worl]d","!"] (quoteWords "  hel[lo  worl]d ! ")
         , assertEqual "Space seperate words, square-bracket at end" ["hel[lo world]"] (quoteWords " hel[lo world]")
         , assertEqual "Space seperate words, double quote at end" ["hello world"] (quoteWords " hel\"lo world\"")
         , assertEqual "Space seperate words, square-bracket at beginning" ["[hello wo]rld","!"] (quoteWords "[hello wo]rld !")
         , assertEqual "Space seperate words, double quote at beginning" ["hello world","!"] (quoteWords "\"hello wor\"ld !")
         ]

testSourcesList :: Test
testSourcesList =
    test [ assertEqual "parse and pretty sources.list" validSourcesListExpected (render . pPrint . PP . parseSourcesList $ validSourcesListStr) ]

testSourcesList2 :: Test
testSourcesList2 =
    test [ assertEqual "pretty sources.list" validSourcesListExpected (render . pPrint . PP $ validSourcesList) ]

validSourcesListStr :: String
validSourcesListStr =
          unlines $ [ " # A comment only line "
                    , " deb ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb line"
                    , " deb-src ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb-src line"
                    , ""
                    , "# comment line"
                    , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ # exact path"
                    , "deb [trusted=yes] http://ftp.debian.org/whee \"space dist\" main"
                    , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section"
                    ]

validSourcesList :: [DebSource]
validSourcesList =
    [DebSource {sourceType = Deb, sourceOptions = [], sourceUri = fromJust (parseURI "ftp://ftp.debian.org/debian"), sourceDist = Right (ReleaseName {relName = "unstable"},[Section "main",Section "contrib",Section "non-free"])},
     DebSource {sourceType = DebSrc, sourceOptions = [], sourceUri = fromJust (parseURI "ftp://ftp.debian.org/debian"), sourceDist = Right (ReleaseName {relName = "unstable"},[Section "main",Section "contrib",Section "non-free"])},
     DebSource {sourceType = Deb, sourceOptions = [], sourceUri = fromJust (parseURI "http://pkg-kde.alioth.debian.org/kde-3.5.0/"), sourceDist = Left "./"},
     DebSource {sourceType = Deb, sourceOptions = [SourceOption "trusted" OpSet ["yes"]], sourceUri = fromJust (parseURI "http://ftp.debian.org/whee"), sourceDist = Right (ReleaseName {relName = "space dist"},[Section "main"])},
     DebSource {sourceType = Deb, sourceOptions = [SourceOption "trusted" OpSet ["yes"]], sourceUri = fromJust (parseURI "http://ftp.debian.org/whee"), sourceDist = Right (ReleaseName {relName = "dist"},[Section "space section"])}]

validSourcesListExpected :: String
validSourcesListExpected =
          unlines $ [ "deb ftp://ftp.debian.org/debian unstable main contrib non-free"
                    , "deb-src ftp://ftp.debian.org/debian unstable main contrib non-free"
                    , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./"
                    , "deb [trusted=yes] http://ftp.debian.org/whee space%20dist main"
                    , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section"
                    ]
_invalidSourcesListStr1 :: Text
_invalidSourcesListStr1 = "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ main contrib non-free # exact path with sections"

testSourcesListParse :: Test
testSourcesListParse =
    test [ assertEqual "" gutsy (concat . map (<> "\n") . map (render . pPrint) . parseSourcesList $ gutsy) ]
    where
      gutsy = concat ["deb http://us.archive.ubuntu.com/ubuntu/ gutsy main restricted universe multiverse\n",
                      "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy main restricted universe multiverse\n",
                      "deb http://us.archive.ubuntu.com/ubuntu/ gutsy-updates main restricted universe multiverse\n",
                      "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy-updates main restricted universe multiverse\n",
                      "deb http://us.archive.ubuntu.com/ubuntu/ gutsy-backports main restricted universe multiverse\n",
                      "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy-backports main restricted universe multiverse\n",
                      "deb http://security.ubuntu.com/ubuntu/ gutsy-security main restricted universe multiverse\n",
                      "deb-src http://security.ubuntu.com/ubuntu/ gutsy-security main restricted universe multiverse\n"]

sourcesListTests :: Test
sourcesListTests =
    TestList [ testQuoteWords, testSourcesList, testSourcesList2, testSourcesListParse ]