Rose E. Shere / Fold Banner

Download as
Browse Code ยป

Commit a9673a53ebc7c7bd42847da645dae36909f3605d

Authored by David Shere
1 parent 300f97ca1c
Exists in master

Changed configuration code a bit to allow for easier undefined defaults.

Showing 4 changed files with 41 additions and 33 deletions Inline Diff

foldbanner.cabal View file @ a9673a5
name: foldbanner 1 1 name: foldbanner
version: 0.1.0.4 2 2 version: 0.1.0.5
synopsis: Folding@home banner generator. 3 3 synopsis: Folding@home banner generator.
description: Foldbanner is a utility for generating Folding@home banners for users and teams. It uses a YAML configuration file containing the keys and positioning for the text on the banner. 4 4 description: Foldbanner is a utility for generating Folding@home banners for users and teams. It uses a YAML configuration file containing the keys and positioning for the text on the banner.
license: MIT 5 5 license: MIT
license-file: LICENSE 6 6 license-file: LICENSE
author: David Shere 7 7 author: David Shere
-- maintainer: 8 8 -- maintainer:
copyright: (c) 2012-2013 David Shere 9 9 copyright: (c) 2012-2013 David Shere
-- category: 10 10 -- category:
build-type: Simple 11 11 build-type: Simple
cabal-version: >=1.8 12 12 cabal-version: >=1.8
13 13
executable foldbanner 14 14 executable foldbanner
main-is: Main.hs 15 15 main-is: Main.hs
-- other-modules: 16 16 -- other-modules:
build-depends: base ==4.6.*, bytestring ==0.10.*, containers ==0.5.*, yaml-light ==0.1.*, split ==0.2.*, cairo ==0.12.*, download-curl ==0.1.*, cmdargs ==0.10.*, directory ==1.2.*, xml ==1.3.* 17 17 build-depends: base ==4.6.*, bytestring ==0.10.*, containers ==0.5.*, yaml-light ==0.1.*, split ==0.2.*, cairo ==0.12.*, download-curl ==0.1.*, cmdargs ==0.10.*, directory ==1.2.*, xml ==1.3.*, JuicyPixels
hs-source-dirs: src 18 18 hs-source-dirs: src
19 19
res/cfg/user.yaml View file @ a9673a5
## Example User Configuration File 1 1 ## Example User Configuration File
2 2
# queryURL is the url used to request the XML user statistics file. 3 3 # queryURL is the url used to request the XML user statistics file.
# This is the url for querying the user database 4 4 # This is the url for querying the user database
query_url: http://folding.extremeoverclocking.com/xml/user_summary.php?u= 5 5 query_url: http://folding.extremeoverclocking.com/xml/user_summary.php?u=
6 6
# Position individual stat positions will be offset from. 7 7 # Position individual stat positions will be offset from.
# Defaults to 0,0 if not defined. Defined here anyway just for the sake of example. 8 8 # Defaults to 0,0
position_origin: 9 9 #position_origin:
x: 0 10 10 # x: 0
y: 0 11 11 # y: 0
12 12
# Default font settings. Any of these may be overridden by defining them 13 13 # Default font settings. Any of these may be overridden by defining them
# in an individual key's configuration section. 14 14 # in an individual key's configuration section.
font_face: monospace # The font to use 15 15 #font_face: monospace # The font to use. Defaults to monospace
font_size: 12 # The font size 16 16 #font_size: 12 # The font size. Defaults to 12
stroke_width: 0.25 # The stroke width to apply to the font. 17 17 #stroke_width: 0.25 # The stroke width to apply to the font. Defaults to 0.25
key_color: # The key color 18 18 key_color: # The key color. Defaults to Black (0,0,0,1)
r: 1.0 19 19 r: 1.0
g: 1.0 20 20 g: 1.0
b: 1.0 21 21 b: 1.0
a: 1.0 22 22 a: 1.0
val_color: # The value color 23 23 val_color: # The value color. Defaults to Black (0,0,0,1)
r: 1.0 24 24 r: 1.0
g: 1.0 25 25 g: 1.0
b: 0.0 26 26 b: 0.0
a: 1.0 27 27 a: 1.0
28 28
# Individual stat configs 29 29 # Individual stat configs
stat_configs: 30 30 stat_configs:
- key: User_Name # XML element name for the statistic. 31 31 - key: User_Name # XML element name for the statistic.
type: user # Type of statistic (user, team, status) 32 32 type: user # Type of statistic (user, team, status)
name: " User: " # Display name for this key. 33 33 name: " User: " # Display name for this key.
use_commas: False # Insert commas every three characters? (True or False) 34 34 # use_commas: False # Insert commas every three characters? Defaults to False
position_offset: # lower left corner of the output for this statistic 35 35 position_offset: # lower left corner of the output for this statistic
x: 12 # as offset from the position_origin 36 36 x: 12 # as offset from the position_origin
y: 20 37 37 y: 20
38 38
- key: Team_Rank 39 39 - key: Team_Rank
type: user 40 40 type: user
name: " Rank on Team: " 41 41 name: " Rank on Team: "
use_commas: True 42 42 use_commas: True
position_offset: 43 43 position_offset:
x: 12 44 44 x: 12
y: 32 45 45 y: 32
46 46
- key: Points_24hr_Avg 47 47 - key: Points_24hr_Avg
type: team 48 48 type: team
name: " Team Daily Avg: " 49 49 name: " Team Daily Avg: "
use_commas: True 50 50 use_commas: True
position_offset: 51 51 position_offset:
x: 203 52 52 x: 203
y: 68 53 53 y: 68
54 54
- key: Points_Today 55 55 - key: Points_Today
type: team 56 56 type: team
name: " Points Today: " 57 57 name: " Points Today: "
use_commas: True 58 58 use_commas: True
position_offset: 59 59 position_offset:
x: 203 60 60 x: 203
y: 80 61 61 y: 80
62 62
- key: Users 63 63 - key: Users
type: team 64 64 type: team
name: " Total Users: " 65 65 name: " Total Users: "
use_commas: True 66 66 use_commas: True
position_offset: 67 67 position_offset:
x: 203 68 68 x: 203
y: 44 69 69 y: 44
70 70
- key: Points 71 71 - key: Points
type: team 72 72 type: team
name: " Team Points: " 73 73 name: " Team Points: "
use_commas: True 74 74 use_commas: True
position_offset: 75 75 position_offset:
x: 203 76 76 x: 203
y: 56 77 77 y: 56
78 78
- key: TeamID 79 79 - key: TeamID
type: team 80 80 type: team
name: " Team: " 81 81 name: " Team: "
use_commas: False 82
position_offset: 83 82 position_offset:
x: 203 84 83 x: 203
y: 20 85 84 y: 20
86 85
- key: Team_Name 87 86 - key: Team_Name
type: team 88 87 type: team
name: " " 89 88 name: " "
use_commas: False 90
position_offset: 91 89 position_offset:
x: 203 92 90 x: 203
y: 20 93 91 y: 20
94 92
- key: Rank 95 93 - key: Rank
type: team 96 94 type: team
name: " Rank of Team: " 97 95 name: " Rank of Team: "
use_commas: True 98 96 use_commas: True
position_offset: 99 97 position_offset:
x: 203 100 98 x: 203
y: 32 101 99 y: 32
102 100
- key: Overall_Rank 103 101 - key: Overall_Rank
type: user 104 102 type: user
name: " Overall Rank: " 105 103 name: " Overall Rank: "
use_commas: True 106 104 use_commas: True
position_offset: 107 105 position_offset:
x: 12 108 106 x: 12
y: 44 109 107 y: 44
110 108
- key: WUs 111 109 - key: WUs
type: user 112 110 type: user
name: " User WUs: " 113 111 name: " User WUs: "
use_commas: True 114 112 use_commas: True
position_offset: 115 113 position_offset:
x: 12 116 114 x: 12
y: 80 117 115 y: 80
118 116
- key: Points 119 117 - key: Points
type: user 120 118 type: user
name: " User Points: " 121 119 name: " User Points: "
use_commas: True 122 120 use_commas: True
position_offset: 123 121 position_offset:
x: 12 124 122 x: 12
y: 56 125 123 y: 56
126 124
- key: Points_24hr_Avg 127 125 - key: Points_24hr_Avg
src/BannerConfig.hs View file @ a9673a5
{-# LANGUAGE OverloadedStrings #-} 1 1 {-# LANGUAGE OverloadedStrings #-}
2 2
module BannerConfig 3 3 module BannerConfig
(BannerConfig( 4 4 (BannerConfig(
BannerConfig 5 5 BannerConfig
,queryURL 6 6 ,queryURL
,originPosition 7 7 ,originPosition
,defaultFontFace 8 8 ,defaultFontFace
,defaultFontSize 9 9 ,defaultFontSize
,defaultKeyColor 10 10 ,defaultKeyColor
,defaultValueColor 11 11 ,defaultValueColor
,defaultStrokeWidth 12 12 ,defaultStrokeWidth
--,defaultUseCommas 13 13 ,defaultUseCommas
,statConfigs) 14 14 ,statConfigs)
,StatConfig( 15 15 ,StatConfig(
StatConfig 16 16 StatConfig
,key 17 17 ,key
,keyType 18 18 ,keyType
,name 19 19 ,name
,position 20 20 ,position
,fontFace 21 21 ,fontFace
,fontSize 22 22 ,fontSize
,keyColor 23 23 ,keyColor
,valueColor 24 24 ,valueColor
,strokeWidth 25 25 ,strokeWidth
,useCommas) 26 26 ,useCommas)
,Color( 27 27 ,Color(
Color 28 28 Color
,red 29 29 ,red
,green 30 30 ,green
,blue 31 31 ,blue
,alpha) 32 32 ,alpha)
,Position( 33 33 ,Position(
Position 34 34 Position
,x 35 35 ,x
,y) 36 36 ,y)
,readBannerConfig) 37 37 ,readBannerConfig)
where 38 38 where
39 39
import qualified Data.ByteString.Char8 as BS 40 40 import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as M 41 41 import qualified Data.Map as M
import Data.Map (Map) 42 42 import Data.Map (Map)
import Data.Maybe 43 43 import Data.Maybe
import Data.Yaml.YamlLight 44 44 import Data.Yaml.YamlLight
45 45
data BannerConfig = BannerConfig 46 46 data BannerConfig = BannerConfig
{ queryURL :: Maybe String 47 47 { queryURL :: Maybe String
, originPosition :: Position -- The origin point for writing stats. 48 48 , originPosition :: Position -- The origin point for writing stats.
, defaultFontFace :: String -- Default settings 49 49 , defaultFontFace :: String -- Default settings
, defaultFontSize :: Double -- 50 50 , defaultFontSize :: Double --
, defaultKeyColor :: Color -- 51 51 , defaultKeyColor :: Color --
, defaultValueColor :: Color -- 52 52 , defaultValueColor :: Color --
, defaultStrokeWidth :: Double -- 53 53 , defaultStrokeWidth :: Double --
--, defaultUseCommas :: Bool -- 54 54 , defaultUseCommas :: Bool --
, statConfigs :: [StatConfig] 55 55 , statConfigs :: [StatConfig]
} deriving (Show) 56 56 } deriving (Show)
57 57
data StatConfig = StatConfig 58 58 data StatConfig = StatConfig
{ key :: String -- The statistic's key, ie: Team_Name or Points 59 59 { key :: String -- The statistic's key, ie: Team_Name or Points
, keyType :: String -- The section the key is in: user, team, status 60 60 , keyType :: String -- The section the key is in: user, team, status
, name :: String -- The name to display for the key 61 61 , name :: String -- The name to display for the key
, position :: Position -- The x,y position for this statistic 62 62 , position :: Position -- The x,y position for this statistic
, fontFace :: Maybe String -- The font to use 63 63 , fontFace :: Maybe String -- The font to use
, fontSize :: Maybe Double -- The font size 64 64 , fontSize :: Maybe Double -- The font size
, keyColor :: Maybe Color -- The color to use for the key name 65 65 , keyColor :: Maybe Color -- The color to use for the key name
, valueColor :: Maybe Color -- The color to use for the value 66 66 , valueColor :: Maybe Color -- The color to use for the value
, strokeWidth :: Maybe Double -- The amount to stroke the text 67 67 , strokeWidth :: Maybe Double -- The amount to stroke the text
, useCommas :: Maybe Bool -- Wether or not to add commas 68 68 , useCommas :: Bool -- Wether or not to add commas
} deriving (Show) 69 69 } deriving (Show)
70 70
data Color = Color 71 71 data Color = Color
{ red :: Double 72 72 { red :: Double
, green :: Double 73 73 , green :: Double
, blue :: Double 74 74 , blue :: Double
, alpha :: Double 75 75 , alpha :: Double
} deriving (Show) 76 76 } deriving (Show)
77 77
data Position = Position 78 78 data Position = Position
{ x :: Double 79 79 { x :: Double
, y :: Double 80 80 , y :: Double
} deriving (Show) 81 81 } deriving (Show)
82 82
83 83
-- Converts a configuration file into a BannerConfig value 84 84 -- Converts a configuration file into a BannerConfig value
readBannerConfig :: FilePath -> IO (Maybe BannerConfig) 85 85 readBannerConfig :: FilePath -> IO (Maybe BannerConfig)
readBannerConfig configFile = do 86 86 readBannerConfig configFile = do
yaml <- parseYamlFile configFile 87 87 yaml <- parseYamlFile configFile
return $ getBannerConfig yaml 88 88 return $ getBannerConfig yaml
where 89 89 where
getBannerConfig map = unMap map >>= makeBannerConfig 90 90 getBannerConfig map = unMap map >>= makeBannerConfig
makeBannerConfig map = Just 91 91 makeBannerConfig map = Just
( BannerConfig 92 92 ( BannerConfig
{ queryURL = getString "query_url" map 93 93 { queryURL = getString "query_url" map
, originPosition = getPosition "position_origin" map 94 94 , originPosition = getPosition "position_origin" map
, defaultFontFace = fromJust $ getString "font_face" map 95 95 , defaultFontFace = fromMaybe "monospace" $ getString "font_face" map
, defaultFontSize = fromJust $ getString "font_size" map >>= toDouble 96 96 , defaultFontSize = fromMaybe 12.0 $ getString "font_size" map >>= toDouble
, defaultKeyColor = fromJust $ getColor "key_color" map 97 97 , defaultKeyColor = fromMaybe (Color 0 0 0 1) $ getColor "key_color" map
, defaultValueColor = fromJust $ getColor "val_color" map 98 98 , defaultValueColor = fromMaybe (Color 0 0 0 1) $ getColor "val_color" map
, defaultStrokeWidth = fromJust $ getString "stroke_width" map >>= toDouble 99 99 , defaultStrokeWidth = fromMaybe 0.25 $ getString "stroke_width" map >>= toDouble
--, defaultUseCommas = getString "use_commas" map >>= toBool 100 100 , defaultUseCommas = fromMaybe False $ getString "use_commas" map >>= toBool
, statConfigs = getStatConfigs map }) 101 101 , statConfigs = getStatConfigs map })
toDouble val = Just (read val :: Double) 102 102 toDouble val = Just (read val :: Double)
toBool val = Just (read val :: Bool) 103 103 toBool val = Just (read val :: Bool)
104 104
105 105
106 106
-- The following functions are all used to access fields of the 107 107 -- The following functions are all used to access fields of the
-- configuration file and convert them into their proper types. 108 108 -- configuration file and convert them into their proper types.
getStatConfigs :: Map YamlLight YamlLight -> [StatConfig] 109 109 getStatConfigs :: Map YamlLight YamlLight -> [StatConfig]
getStatConfigs map = case lookup of 110 110 getStatConfigs map = case lookup of
Nothing -> [] 111 111 Nothing -> []
Just val -> val 112 112 Just val -> val
where 113 113 where
lookup = M.lookup (YStr "stat_configs") map >>= unSeq 114 114 lookup = M.lookup (YStr "stat_configs") map >>= unSeq
>>= mapM (\cfgMap -> Just (getStatConfig (unMap cfgMap))) 115 115 >>= mapM (\cfgMap -> Just (getStatConfig (unMap cfgMap)))
getStatConfig map = StatConfig { 116 116 getStatConfig map = StatConfig {
key = fromJust $ getString "key" (fromJust map), 117 117 key = fromMaybe "null" $ getString "key" (fromJust map),
keyType = fromJust $ getString "type" (fromJust map), 118 118 keyType = fromMaybe "null" $ getString "type" (fromJust map),
name = fromJust $ getString "name" (fromJust map), 119 119 name = fromMaybe "null" $ getString "name" (fromJust map),
position = getPosition "position_offset" (fromJust map), 120 120 position = getPosition "position_offset" (fromJust map),
fontFace = getString "font_face" (fromJust map), 121 121 fontFace = getString "font_face" (fromJust map),
fontSize = getString "font_size" (fromJust map) >>= toDouble, 122 122 fontSize = getString "font_size" (fromJust map) >>= toDouble,
keyColor = getColor "key_color" (fromJust map), 123 123 keyColor = getColor "key_color" (fromJust map),
valueColor = getColor "val_color" (fromJust map), 124 124 valueColor = getColor "val_color" (fromJust map),
strokeWidth = getString "stroke_width" (fromJust map) >>= toDouble, 125 125 strokeWidth = getString "stroke_width" (fromJust map) >>= toDouble,
useCommas = getString "use_commas" (fromJust map) >>= toBool 126 126 useCommas = fromMaybe False $ getString "use_commas" (fromJust map) >>= toBool
} 127 127 }
toDouble val = Just (read val :: Double) 128 128 toDouble val = Just (read val :: Double)
toBool val = Just (read val :: Bool) 129 129 toBool val = Just (read val :: Bool)
130 130
getValue :: BS.ByteString -> Map YamlLight YamlLight -> Maybe YamlLight 131 131 getValue :: BS.ByteString -> Map YamlLight YamlLight -> Maybe YamlLight
getValue key map = M.lookup (YStr key) map 132 132 getValue key map = M.lookup (YStr key) map
133 133
getString :: BS.ByteString -> Map YamlLight YamlLight -> Maybe String 134 134 getString :: BS.ByteString -> Map YamlLight YamlLight -> Maybe String
getString key map = getValue key map >>= unStr >>= (\bs -> (Just (BS.unpack bs))) 135 135 getString key map = getValue key map >>= unStr >>= (\bs -> (Just (BS.unpack bs)))
136 136
getColor :: BS.ByteString -> Map YamlLight YamlLight -> Maybe Color 137 137 getColor :: BS.ByteString -> Map YamlLight YamlLight -> Maybe Color
getColor key map = getValue key map >>= unMap >>= makeColor 138 138 getColor key map = getValue key map >>= unMap >>= makeColor
where 139 139 where
makeColor map = Just (Color 140 140 makeColor map = Just (Color
(fromJust (getString "r" map >>= toDouble)) 141 141 (fromMaybe 0 (getString "r" map >>= toDouble))
(fromJust (getString "g" map >>= toDouble)) 142 142 (fromMaybe 0 (getString "g" map >>= toDouble))
(fromJust (getString "b" map >>= toDouble)) 143 143 (fromMaybe 0 (getString "b" map >>= toDouble))
(fromJust (getString "a" map >>= toDouble))) 144 144 (fromMaybe 1 (getString "a" map >>= toDouble)))
toDouble val = Just (read val :: Double) 145 145 toDouble val = Just (read val :: Double)
146 146
getPosition :: BS.ByteString -> Map YamlLight YamlLight -> Position 147 147 getPosition :: BS.ByteString -> Map YamlLight YamlLight -> Position
getPosition key map = case M.lookup (YStr key) map of 148 148 getPosition key map = case M.lookup (YStr key) map of
Nothing -> Position 0 0 149 149 Nothing -> Position 0 0
Just map -> makePosition $ fromJust $ unMap map 150 150 Just map -> makePosition $ fromJust $ unMap map
where 151 151 where
makePosition map = Position 152 152 makePosition map = Position
(fromJust (getString "x" map >>= toDouble)) 153 153 (fromJust (getString "x" map >>= toDouble))
(fromJust (getString "y" map >>= toDouble)) 154 154 (fromJust (getString "y" map >>= toDouble))
toDouble val = Just (read val :: Double) 155 155 toDouble val = Just (read val :: Double)
156 156
src/Main.hs View file @ a9673a5
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} 1 1 {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2 2
-- This program creates a statistics image banner for a user or team 3 3 -- This program creates a statistics image banner for a user or team
-- involved in Folding@home. I used the singleMode.hs example from 4 4 -- involved in Folding@home. I used the singleMode.hs example from
-- http://zuttobenkyou.wordpress.com/2011/04/19/haskell-using-cmdargs-single-and-multi-mode/ 5 5 -- http://zuttobenkyou.wordpress.com/2011/04/19/haskell-using-cmdargs-single-and-multi-mode/
-- to make the commandline options for this program look pretty. 6 6 -- to make the commandline options for this program look pretty.
7 7
import BannerConfig 8 8 import BannerConfig
import Control.Monad (when) 9 9 import Control.Monad (when)
import Data.Char 10 10 import Data.Char
import Data.List 11 11 import Data.List
import Data.List.Split 12 12 import Data.List.Split
import Data.Maybe 13 13 import Data.Maybe
import Graphics.Rendering.Cairo 14 14 import Graphics.Rendering.Cairo
import Network.Curl.Download 15 15 import Network.Curl.Download
import System.Console.CmdArgs 16 16 import System.Console.CmdArgs
import qualified System.Console.CmdArgs as CA 17 17 import qualified System.Console.CmdArgs as CA
import System.Directory 18 18 import System.Directory
import System.Environment (getArgs, withArgs) 19 19 import System.Environment (getArgs, withArgs)
import System.Exit 20 20 import System.Exit
import Text.XML.Light 21 21 import Text.XML.Light
import Text.XML.Light.Cursor 22 22 import Text.XML.Light.Cursor
import Text.XML.Light.Input 23 23 import Text.XML.Light.Input
24 import Codec.Picture.Bitmap
25 import Codec.Picture.Png
26 import Codec.Picture.Jpg
27 import Codec.Picture.Gif
28 import Codec.Picture.Saving
24 29
30
data MyOptions = MyOptions 25 31 data MyOptions = MyOptions
{ config :: FilePath 26 32 { config :: FilePath
, background :: FilePath 27 33 , background :: FilePath
, output :: FilePath 28 34 , output :: FilePath
, stats :: FilePath 29 35 , stats :: FilePath
, ident :: String 30 36 , ident :: String
} deriving (Data, Typeable, Show, Eq) 31 37 } deriving (Data, Typeable, Show, Eq)
32 38
-- Customize your options, including help messages, shortened names, etc. 33 39 -- Customize your options, including help messages, shortened names, etc.
myProgOpts :: MyOptions 34 40 myProgOpts :: MyOptions
myProgOpts = MyOptions 35 41 myProgOpts = MyOptions
{ config = def &= typFile &= help "the banner configuration file" 36 42 { config = def &= typFile &= help "the banner configuration file"
, background = def &= typFile &= help "the background image (must be png)" 37 43 , background = def &= typFile &= help "the background image (must be png)"
, output = def &= typFile &= help "the output file (must be png)" 38 44 , output = def &= typFile &= help "the output file (must be png)"
, stats = def &= typFile &= help "the xml statistics file (from extremeoverclocking.com)" 39 45 , stats = def &= typFile &= help "the xml statistics file (from extremeoverclocking.com)"
, ident = def &= typ "ID" &= help "the user or team id" } 40 46 , ident = def &= typ "ID" &= help "the user or team id" }
41 47
getOpts :: IO MyOptions 42 48 getOpts :: IO MyOptions
getOpts = cmdArgs $ myProgOpts 43 49 getOpts = cmdArgs $ myProgOpts
&= verbosityArgs [explicit, CA.name "Verbose", CA.name "V"] [] 44 50 &= verbosityArgs [explicit, CA.name "Verbose", CA.name "V"] []
&= versionArg [explicit, CA.name "version", CA.name "v", summary _PROGRAM_INFO] 45 51 &= versionArg [explicit, CA.name "version", CA.name "v", summary _PROGRAM_INFO]
&= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT) 46 52 &= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT)
&= help _PROGRAM_ABOUT 47 53 &= help _PROGRAM_ABOUT
&= helpArg [explicit, CA.name "help", CA.name "h"] 48 54 &= helpArg [explicit, CA.name "help", CA.name "h"]
&= program _PROGRAM_NAME 49 55 &= program _PROGRAM_NAME
50 56
_PROGRAM_NAME = "foldbanner" 51 57 _PROGRAM_NAME = "foldbanner"
_PROGRAM_VERSION = "1.0.4" 52 58 _PROGRAM_VERSION = "1.0.5"
_PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION 53 59 _PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION
_PROGRAM_ABOUT = "A configurable program for generating statistics banners for Folding@home" 54 60 _PROGRAM_ABOUT = "A configurable program for generating statistics banners for Folding@home"
_COPYRIGHT = "(c) 2012-2013 David Shere" 55 61 _COPYRIGHT = "(c) 2012-2013 David Shere"
56 62
main :: IO () 57 63 main :: IO ()
main = do 58 64 main = do
args <- getArgs 59 65 args <- getArgs
-- If the user did not specify any arguments, pretend as "--help" was given 60 66 -- If the user did not specify any arguments, pretend as "--help" was given
opts <- (if null args then withArgs ["--help"] else id) getOpts 61 67 opts <- (if null args then withArgs ["--help"] else id) getOpts
optionHandler opts 62 68 optionHandler opts
63 69
-- Before directly calling your main program, you should warn your user about incorrect arguments, if any. 64 70 -- Before directly calling your main program, you should warn your user about incorrect arguments, if any.
optionHandler :: MyOptions -> IO () 65 71 optionHandler :: MyOptions -> IO ()
optionHandler opts@MyOptions{..} = do 66 72 optionHandler opts@MyOptions{..} = do
-- Get some error values 67 73 -- Get some error values
bgExists <- doesFileExist background 68 74 bgExists <- doesFileExist background
cfgExists <- doesFileExist config 69 75 cfgExists <- doesFileExist config
-- Take the opportunity here to weed out ugly, malformed, or invalid arguments. 70 76 -- Take the opportunity here to weed out ugly, malformed, or invalid arguments.
when (null config) $ putStrLn "--config is blank!" >> exitWith (ExitFailure 1) 71 77 when (null config) $ putStrLn "--config is blank!" >> exitWith (ExitFailure 1)
when (null background) $ putStrLn "--background is blank!" >> exitWith (ExitFailure 1) 72 78 when (null background) $ putStrLn "--background is blank!" >> exitWith (ExitFailure 1)
when (not cfgExists) $ putStrLn ("config file \"" ++ config ++ "\" doesn't exist.") >> exitWith (ExitFailure 1) 73 79 when (not cfgExists) $ putStrLn ("config file \"" ++ config ++ "\" doesn't exist.") >> exitWith (ExitFailure 1)
when (not bgExists) $ putStrLn ("background file \"" ++ background ++ "\" doesn't exist") >> exitWith (ExitFailure 1) 74 80 when (not bgExists) $ putStrLn ("background file \"" ++ background ++ "\" doesn't exist") >> exitWith (ExitFailure 1)
when (not (isSuffixOf ".png" (map toLower background))) $ putStrLn "background file isn't a PNG image" >> exitWith (ExitFailure 1) 75 81 when (not (isSuffixOf ".png" (map toLower background))) $ putStrLn "background file isn't a PNG image" >> exitWith (ExitFailure 1)
when (null output) $ putStrLn "--output is blank!" >> exitWith (ExitFailure 1) 76 82 when (null output) $ putStrLn "--output is blank!" >> exitWith (ExitFailure 1)
when (not (null ident) && not (null stats)) $ putStrLn "--ident and --stats are both defined! Use one!" >> exitWith (ExitFailure 1) 77 83 when (not (null ident) && not (null stats)) $ putStrLn "--ident and --stats are both defined! Use one!" >> exitWith (ExitFailure 1)
when (null ident && null stats) $ putStrLn "--ident and --stats are blank! Use one!" >> exitWith (ExitFailure 1) 78 84 when (null ident && null stats) $ putStrLn "--ident and --stats are blank! Use one!" >> exitWith (ExitFailure 1)
-- When you're done, pass the (corrected, or not) options to your actual program. 79 85 -- When you're done, pass the (corrected, or not) options to your actual program.
exec opts 80 86 exec opts
81 87
exec :: MyOptions -> IO () 82 88 exec :: MyOptions -> IO ()
exec opts@MyOptions{..} = do 83 89 exec opts@MyOptions{..} = do
cfg <- readBannerConfig config 84 90 cfg <- readBannerConfig config
case cfg of 85 91 case cfg of
Nothing -> putStrLn "Error loading config file." >> exitWith (ExitFailure 1) 86 92 Nothing -> putStrLn "Error loading config file." >> exitWith (ExitFailure 1)
Just cfg -> do 87 93 Just cfg -> do
case (null stats) of 88 94 case (null stats) of
True -> do 89 95 True -> do
stats <- getStats cfg (StatID ident) 90 96 stats <- getStats cfg (StatID ident)
case stats of 91 97 case stats of
Nothing -> putStrLn "Error retrieving stats." 92 98 Nothing -> putStrLn "Error retrieving stats."
Just s -> createBanner cfg s output background 93 99 Just s -> createBanner cfg s output background
False -> do 94 100 False -> do
stats <- getStats cfg (StatFile stats) 95 101 stats <- getStats cfg (StatFile stats)
case stats of 96 102 case stats of
Nothing -> putStrLn "Error reading stats." 97 103 Nothing -> putStrLn "Error reading stats."
Just s -> createBanner cfg s output background 98 104 Just s -> createBanner cfg s output background
99 105
------------------------------------------------------------------------------- 100 106 -------------------------------------------------------------------------------
101 107
data StatSource = StatFile FilePath | StatID String 102 108 data StatSource = StatFile FilePath | StatID String
103 109
-- Retrieve the statistics from the statistics server or local file 104 110 -- Retrieve the statistics from the statistics server or local file
getStats :: BannerConfig -> StatSource -> IO (Maybe Element) 105 111 getStats :: BannerConfig -> StatSource -> IO (Maybe Element)
getStats cfg (StatID id) = do 106 112 getStats cfg (StatID id) = do
case queryURL cfg of 107 113 case queryURL cfg of
Nothing -> putStrLn "No query_url in config file." >> exitWith (ExitFailure 1); 108 114 Nothing -> putStrLn "No query_url in config file." >> exitWith (ExitFailure 1);
Just val -> do 109 115 Just val -> do
xml <- openAsXML $ val ++ id 110 116 xml <- openAsXML $ val ++ id
case xml of 111 117 case xml of
Left e -> do 112 118 Left e -> do
putStrLn e 113 119 putStrLn e
return Nothing 114 120 return Nothing
Right stats -> return $ Just ((onlyElems stats) !! 1) 115 121 Right stats -> return $ Just ((onlyElems stats) !! 1)
116 122
getStats cfg (StatFile file) = do 117 123 getStats cfg (StatFile file) = do
xmlFile <- readFile file 118 124 xmlFile <- readFile file
return $ parseXMLDoc xmlFile 119 125 return $ parseXMLDoc xmlFile
120 126
-- Create the statistics banner and save it to the output file 121 127 -- Create the statistics banner and save it to the output file
createBanner :: BannerConfig -> Element -> FilePath -> FilePath -> IO () 122 128 createBanner :: BannerConfig -> Element -> FilePath -> FilePath -> IO ()
createBanner mainConfig stats out bg = withImageSurfaceFromPNG bg $ \surface -> do 123 129 createBanner mainConfig stats out bg = withImageSurfaceFromPNG bg $ \surface -> do
renderWith surface $ do mapM_ writeStat $ statConfigs mainConfig 124 130 renderWith surface $ do mapM_ writeStat $ statConfigs mainConfig
131 --image <- imageSurfaceGetData surface
132 --case decodeBitmap image of
133 -- Left err -> putStrLn err >> exitWith (ExitFailure 1)
134 -- Right img -> writeDynamicPng out img
surfaceWriteToPNG surface out 125 135 surfaceWriteToPNG surface out
return () 126 136 return ()
where 127 137 where
getData keyType key = case findElementByName keyType key stats of 128 138 getData keyType key = case findElementByName keyType key stats of
Nothing -> "Error" 129 139 Nothing -> "Error"
Just e -> strContent e 130 140 Just e -> strContent e
findElementByName keyType key stats = findElement (unqual key) $ 131 141 findElementByName keyType key stats = findElement (unqual key) $
fromJust $ findElement (unqual keyType) stats 132 142 fromJust $ findElement (unqual keyType) stats
addCommas x = h++t -- addCommas function based on code from here: 133 143 addCommas x = h++t -- addCommas function based on code from here:
where -- http://stackoverflow.com/a/3753207/816685 134 144 where -- http://stackoverflow.com/a/3753207/816685
sp = break (== '.') x 135 145 sp = break (== '.') x
h = reverse (intercalate "," $ chunksOf 3 $ reverse $ fst sp) 136 146 h = reverse (intercalate "," $ chunksOf 3 $ reverse $ fst sp)
t = snd sp 137 147 t = snd sp
writeStat cfg = do 138 148 writeStat cfg = do
selectFontFace statFontFace FontSlantNormal FontWeightNormal 139 149 selectFontFace statFontFace FontSlantNormal FontWeightNormal
setFontSize statFontSize 140 150 setFontSize statFontSize
let value = if fromJust $ useCommas cfg 141 151 let value = if useCommas cfg
then do addCommas $ getData (keyType cfg) (key cfg) 142 152 then do addCommas $ getData (keyType cfg) (key cfg)
else getData (keyType cfg) (key cfg) 143 153 else getData (keyType cfg) (key cfg)
writeText (BannerConfig.name cfg) value statKeyColor statValueColor statStrokeWidth (originPosition mainConfig) (position cfg) 144 154 writeText (BannerConfig.name cfg) value statKeyColor statValueColor statStrokeWidth (originPosition mainConfig) (position cfg)
where 145 155 where
statFontFace = case fontFace cfg of 146 156 statFontFace = case fontFace cfg of
Nothing -> defaultFontFace mainConfig 147 157 Nothing -> defaultFontFace mainConfig
Just val -> val 148 158 Just val -> val
statFontSize = case fontSize cfg of 149 159 statFontSize = case fontSize cfg of
Nothing -> defaultFontSize mainConfig 150 160 Nothing -> defaultFontSize mainConfig
Just val -> val 151 161 Just val -> val
statKeyColor = case keyColor cfg of 152 162 statKeyColor = case keyColor cfg of
Nothing -> defaultKeyColor mainConfig 153 163 Nothing -> defaultKeyColor mainConfig
Just val -> val 154 164 Just val -> val
statValueColor = case valueColor cfg of 155 165 statValueColor = case valueColor cfg of
Nothing -> defaultValueColor mainConfig 156 166 Nothing -> defaultValueColor mainConfig
Just val -> val 157 167 Just val -> val
statStrokeWidth = case strokeWidth cfg of 158 168 statStrokeWidth = case strokeWidth cfg of
Nothing -> defaultStrokeWidth mainConfig 159 169 Nothing -> defaultStrokeWidth mainConfig
Just val -> val 160 170 Just val -> val
161 171
-- Write a string with a color and position to the surface. 162 172 -- Write a string with a color and position to the surface.
writeText :: String -> String -> Color -> Color -> Double -> Position -> Position -> Render () 163 173 writeText :: String -> String -> Color -> Color -> Double -> Position -> Position -> Render ()
writeText keyString valString keyColor valColor strokeWidth (Position orgX orgY) (Position x y) = do 164 174 writeText keyString valString keyColor valColor strokeWidth (Position orgX orgY) (Position x y) = do
165 175
s <- status 166 176 s <- status
case s of 167 177 case s of
StatusSuccess -> render 168 178 StatusSuccess -> render
StatusNoMemory -> liftIO $ putStrLn "Error rendering image. Was the background image a valid PNG image?" >> exitWith (ExitFailure 1) 169 179 StatusNoMemory -> liftIO $ putStrLn "Error rendering image. Was the background image a valid PNG image?" >> exitWith (ExitFailure 1)
170 180
where 171 181 where
render = do 172 182 render = do