SourcesList.hs

module Linspire.Debian.SourcesList
    (DebSource(DebSource),
     SourceType(Deb, DebSrc),
     parseSourceLine,	-- String -> DebSource
     parseSourcesList,	-- String -> [DebSource]
     quoteWords,	-- String -> [String]
     archFiles)		-- FilePath -> Maybe String -> DebSource -> [FilePath]
    where

import Control.Exception
import Data.List
import Network.URI

{-

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.

-}

data SourceType
    = Deb | DebSrc
    deriving Eq
      
instance Show SourceType where
    show Deb = "deb"
    show DebSrc = "deb-src"

data DebSource 
    = DebSource 
    { sourceType :: SourceType
    , sourceUri :: URI
    , sourceDist :: Either String (String, [String]) -- ^ Either (ExactPath) (Distribution, [Section])
    }
    deriving Eq

instance Show DebSource where
    show (DebSource thetype theuri thedist) =
        (show thetype) ++" "++ (uriToString id theuri " ") ++
        case thedist of
          Left exactPath -> escape exactPath
          Right (dist, sections) ->
              (escape dist) ++ " " ++ concat (intersperse " " (map escape sections))
        where escape = escapeURIString isAllowedInURI

-- |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' Nothing (dropWhile (==' ') s)
    where
      quoteWords' :: Maybe Char -> String -> [String]
      quoteWords' Nothing [] = []
      quoteWords' Nothing str =
          case break (flip elem " [\"") str of
            ([],[]) -> []
            (w, []) -> [w]
            (w, (' ':rest)) -> w : (quoteWords' Nothing (dropWhile (==' ') rest))
            (w, ('"':rest)) ->
                case break (== '"') rest of
                  (w',('"':rest)) ->
                      case quoteWords' Nothing rest of
                        [] ->  [w ++ w']
                        (w'':ws) -> ((w ++ w' ++ w''): ws)
                  (w',[]) -> error ("quoteWords: missing \" in the string: "  ++ s)
            (w, ('[':rest)) ->
                case break (== ']') rest of
                  (w',(']':rest)) ->
                      case quoteWords' Nothing rest of
                        []       -> [w ++ "[" ++ w' ++ "]"]
                        (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws)
                  (w',[]) -> error ("quoteWords: missing ] in the string: "  ++ s)

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 =
    case quoteWords str of
      (theTypeStr : theUriStr : theDistStr : sectionStrs) ->
          let 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 sectionStrs
                      then DebSource { sourceType = theType, 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 sectionStrs
                    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, sourceUri = theUri, sourceDist = Right (theDist, map unEscapeString sectionStrs) }
      _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str)
            
parseSourcesList :: String -> [DebSource]
parseSourcesList = map parseSourceLine . sourceLines

-- |Return the list of files that apt-get update would write into
-- \/var\/lib\/apt\/lists when it processed the given list of DebSource.
-- FIXME: remove the root argument from this and just return the names.
archFiles :: FilePath -> Maybe String -> DebSource -> [FilePath]
archFiles root (Just arch) deb@(DebSource Deb _ _) =
    map (++ ("_binary-" ++ arch ++ "_Packages")) (archFiles' root deb)
archFiles root Nothing deb@(DebSource DebSrc _ _) =
    map (++ "_source_Sources") (archFiles' root deb)
archFiles _ _ _ = []	-- error?

archFiles' :: FilePath -> DebSource -> [FilePath]
archFiles' root deb =
    let uri = sourceUri deb
        distro = sourceDist deb in
    let scheme = uriScheme uri
        auth = uriAuthority uri
        path = uriPath uri in
    let userpass = maybe "" uriUserInfo auth
        reg = maybeOfString $ maybe "" uriRegName auth
        port = maybe "" uriPort auth in
    let (user, pass) = break (== ':') userpass in
    let user' = maybeOfString user
        pass' = maybeOfString pass in
    let uriText = prefix scheme user' pass' reg port path in
    -- what about dist?
    either (\ exact -> [root ++ (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText ++ escape exact))])
           (\ (dist, sections) ->
                map (\ section -> root ++ (escapeURIString (/= '@')
                                           ("/var/lib/apt/lists/" ++
                                            uriText ++
                                            "_dists_" ++ escape dist ++ "_" ++
                                            escape section)))
                    sections)
           distro
    where
      -- If user is given and password is not, the user name is
      -- added to the file name.  Otherwise it is not.  Really.
      prefix "http:" (Just user) Nothing (Just host) port path =
          user ++ host ++ port ++ escape path
      prefix "http:" _ _ (Just host) port path =
          host ++ port ++ escape path
      prefix "ftp:" _ _ (Just host) _ path =
          host ++ escape path
      prefix "file:" Nothing Nothing Nothing "" path =
          escape path
      prefix "ssh:" (Just user) Nothing (Just host) port path =
          user ++ host ++ port ++ escape path
      prefix "ssh" _ _ (Just host) port path =
          host ++ port ++ escape path
      prefix _ _ _ _ _ _ = error ("invalid DebSource: " ++ show deb)
      maybeOfString "" = Nothing
      maybeOfString s = Just s
      escape s = consperse "_" (wordsBy (== '/') s)

-- |The mighty consperse function
consperse :: [a] -> [[a]] -> [a]
consperse sep items = concat (intersperse sep items)

wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]]
wordsBy p s = 
    case (break p s) of
      (s, []) -> [s]
      (h, t) -> h : wordsBy p (drop 1 t)